爱华网计算机 2009-12-10 18:52:04 阅读922 评论4 字号：大中小
最完美的利用EXCEL自动批量发送邮件
默认分类 2009-08-03 12:44 阅读418评论2
字号： 大大 中中 小小
在网上查找了一些资料,编写了以下这个宏.自认为最完美了,利用EXCEL批量自动发邮件.
经测试在OUTLOOK 2000中不会显示警告窗口.
需要注意一点,邮件的标题不能使用中文,否则不能自动放送!
Sub 自动发送邮件()
'
'要能正确发送并需要对Microseft Outlook进行有效配置
On Error Resume Next
Dim rowCount, endRowNo
'要正常运行下面这句,要将工具/引用中的Microseft Outlook *.0 Object Library(其中*为你Microseft Outlook的版本号)选上
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
'取得当前工作表与Cells(1,1)相连的数据区行数
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
'创建objOutlook为Outlook应用程序对象
Set objOutlook = New Outlook.Application
'开始循环发送电子邮件
For rowCount = 2 To endRowNo
'创建objMail为一个邮件对象
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
'设置收件人地址（从通讯录表的'E-mail地址'字段中获得）
.To = Cells(rowCount, 1)
'设置抄送人地址（从通讯录表的'E-mail地址'字段中获得）
.CC = Cells(rowCount, 2)
'设置邮件主题
.Subject = Cells(rowCount, 3)
'设置邮件内容（从通讯录表的'内容'字段中获得）
.Body = Cells(rowCount, 4) + Chr(10) + Chr(10)
'设置附件（从通讯录表的'附件'字段中获得）
If Range("E" & rowCount).Value <> "" Then
.Attachments.Add Range("E" & rowCount).Value
End If
'显示邮件
.Display
End With
On Error GoTo continue
SendEmail:
AppActivate objMail
DoEvents
SendKeys "%s", Wait:=True '特别注意此处，该项表示相关于在邮件编辑窗口中，单击发送按钮
DoEvents
AppActivate objMail
GoTo SendEmail
continue:
On Error GoTo 0
' Set bjOutlook = Nothing
Set objMail = Nothing
Next
'销毁objOutlook对象
Set objOutlook = Nothing
'所有电子邮件发送完成时提示
'MsgBox rowCount - 1 & "个朋友的问候信发送成功！"
'
If Application.Workbooks.Count = 1 Then
Application.Quit
Else
Workbooks("自动发邮件.xls").Close
End If
'
End Sub
