由于工作需要给单位内每个人发送有关个人信息的邮件，给每个人发送的附件都不一样。没学过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
