VBA代码、批量群发邮箱方法（2）

实现功能：批量群发邮箱

感觉这个比前面分享的那个方法发送邮箱要快点。

需要Excel模板订制请私聊

下面是代码分享

前期准备设置

前面都设置好了，就把下面代码写入进去

Sub cdosendmail()

Dim cdomail As Object

Dim strpath As String

Dim adata As Variant

Dim i As Long

Dim strurl As String

Dim strfrommail As String

Dim strpassword As String

strfrommail = Range('b2').Value

strfromname = Range('b3').Value

If strfrommail = '' Or strfromname = '' Then

MsgBox '未输入邮箱地址或名称'

Exit Sub

End If

strpassword = Range('b4').Value

If strpassword = '' Then

MsgBox '未输入smtp服务密码'

Exit Sub

End If

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

Sheets('数据').Select

adata = Range('a1:c' & Cells(Rows.Count, 1).End(xlUp).Row)

'------数据装入数组aData

strpath = ThisWorkbook.Path & '\暑假快乐.jpg'

'------附件存放的路径+名称

'On Error Resume Next

For i = 2 To UBound(adata)

Set cdomail = CreateObject('cdo.message')

'------创建CDO对象

cdomail.from = strfrommail

'------发信人的邮箱

cdomail.to = adata(i, 1)

'------收信人的邮箱

cdomail.Subject = adata(i, 2)

'------邮件的主题

cdomail.htmlbody = adata(i, 3)

'------邮件的内容（Html格式）

cdomail.textbody = adata(i, 3)

'------邮件的内容（文本格式）

cdomail.addattachment strpath

'------邮件的附件

strurl = 'http://schemas.microsoft.com/cdo/configuration/'

'------微软服务器网址

With cdomail.configuration.Fields

.Item(strurl & 'smtpserver') = 'smtp.qq.com'

'------SMTP服务器地址

.Item(sturl & 'smtpserverport') = 25

'------SMTP服务器端口

.Item(strurl & 'sendusing') = 2

'------发送端口

.Item(strurl & 'smtpauthenticate') = 1

'------远程服务器验证

.Item(strurl & 'sendusername') = strfromname

'-------发送方邮箱名称

.Item(strurl & 'sendpassword') = strpassword

'-------发送方smtp密码

.Item(strurl & 'smtpconnectiontimeout') = 60

'-------设置连接超时（秒）

.Update

End With

cdomail.send

'-------发送

If Err.Number = 0 Then

adata(i, 3) = '发送成功'

Else

adata(i, 3) = '发送失败'

End If

Next

Range('d1').Resize(UBound(adata), 1) = Application.Index(adata, , 3)

Range('d1') = '发送状态'

Set cdomail = Nothing

With Application

.ScreenUpdating = True

.DisplayAlerts = True

End With

MsgBox '您好，发送任务完成'

End Sub

'如果要使用163邮箱发送邮件。修改发件人的邮箱地址、名称和对应的smtp服务密码

'将 .Item(strURL & 'smtpserver')='smtp.qq.com' 改为 .Item(strURL & 'smtpserver')='smtp.163.com'

'如果将一封邮件发送多人，不同收件人之间使用半角分号间隔即可。

'例：'[e-mail];[e-mail]'