vba自动发邮件（通过QQ邮件发单个邮件）

声明：在“看见星光”的原代码基础上修改成个人定制版，感谢“看见星光”同志，下面我们就来说一说关于vba自动发邮件?我们一起去了解并探讨一下这个问题吧!

vba自动发邮件

声明：在“看见星光”的原代码基础上修改成个人定制版，感谢“看见星光”同志！

=================================

Sub 发邮件()

Dim CDOMail As Object

Dim strPath As String

Dim appendix As String

Dim aData As Variant

Dim i As Long

Dim strURL As String

Dim strFromMail As String

Dim strFromName As String

Dim strPassWord As String

strFromMail = "发件人邮箱"

strFromName = "发件人名称"

strPassWord = "发件人授权码"

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

strPath = newname'--------附件路径

On Error Resume Next

Set CDOMail = CreateObject("CDO.Message") '--------创建CDO对象

CDOMail.From = "发件人邮箱" '--------发信人的邮箱

CDOMail.To = "收件人邮箱" '--------收信人的邮箱

CDOMail.Subject = "我是主题" '--------邮件的主题

' CDOMail.HtmlBody = aData(i, 3) '--------邮件的内容（Html格式)

CDOMail.TextBody = "我是内容" '--------邮件的内容（文本格式)

CDOMail.AddAttachment strPath '--------邮件的附件

strURL = "http://schemas.microsoft.com/cdo/configuration/" '--------微软服务器网址

With CDOMail.Configuration.Fields

.Item(strURL & "smtpserver") = "smtp.qq.com" '--------SMTP服务器地址

.Item(strURL & "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.AddAttachment ThisWorkbook.Path & "\" & strArray(i)

' appendix = "a.xlsx"

' CDOMail.AddAttachment newname

CDOMail.Send '--------发送

If Err.Number = 0 Then

MsgBox "邮件发送成功！"

Else

MsgBox "邮件发送失败！"

End If

Set CDOMail = Nothing

With Application

.ScreenUpdating = True

.DisplayAlerts = True

End With

End Sub