批量按照邮件清单发送邮件

Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open _
("E:\Mailinglist.xls") '指向姓名和邮件地址列表的路径

intRow = 1

Do Until objExcel.Cells(intRow,1).Value = ""

Set objEmail = CreateObject("CDO.Message")

objEmail.From = """发件人姓名"" "
objEmail.To = objExcel.Cells(intRow, 2).Value
objEmail.Subject = "邮件主题"
objEmail.Textbody = "邮件文本部分的内容"
objEmail.AddAttachment "E:\Contenu.doc" '附件所在的路径

objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 1
' 1 = cdoSendUsingPickup; 2 = cdoSendUsingPort; 3 = cdoSendUsingExchange
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendemailaddress") = "contact@sender.com"
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpaccountname") = "contact@sender.com"
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "发件人姓名"
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = ""
' objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/postusername") = "发件人姓名"
' objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/postpassword") = ""
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.sender.com"
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 'SMTP端口

objEmail.Configuration.Fields.Update

objEmail.Send

intRow = intRow + 1

Loop
objExcel.Quit

Bookmark this post: