VBA用CDO批量发送邮件

由于工作需要给单位内每个人发送有关个人信息的邮件，给每个人发送的附件都不一样。没学过VBA，上网搜索有很多相关的教程，使用的是QQ邮箱，事先要开通SMTP服务获取授权密码。希望能给有需要的人一些帮助。

Sub CDOEMAIL()
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 2).End(3).Row '读取数据行数
’ MsgBox (lr) '显示数据行数
Dim cm As Variant
For i = 2 To lr '循环，从第2行开始
Const Email_From = “XXX@qq.com” '用于发送的邮箱号码
Const Password = “XXX” '邮箱密码，必须是开通SMTP服务后获得的授权密码
'Const Email_To = Sheet1.Range(“B” & i)
Set cm = CreateObject(“CDO.Message”)

cm.Subject = Sheet1.Range(“C” & i) '邮件主题，从C2开始
cm.From = Email_From
cm.To = Sheet1.Range(“B” & i) '收件人邮箱，从B2开始
cm.TextBody = Sheet1.Range(“D” & i) '邮件内容,D2
cm.AddAttachment Sheet1.Range(“E” & i) '附件路径，E2
Const schema = “http://schemas.microsoft.com/cdo/configuration/” '微软邮件服务器网址

With cm.Configuration.Fields
.Item(schema & “sendusing”) = 2 '发送端口
.Item(schema & “smtpserver”) = “smtp.qq.com” 'SMTP服务器地址
.Item(schema & “smtpauthenticate”) = 1
.Item(schema & “sendusername”) = Email_From '发送邮箱名称
.Item(schema & “sendpassword”) = Password '发送邮箱密码
.Item(schema & “smtpserverport”) = 465 'SMTP服务器端口
.Item(schema & “smtpusessl”) = True
.Item(schema & “smtpconnectiontimeout”) = 60
.Update
End With
cm.Send
Set cm = Nothing
Next
End Sub