[分享] 跟我来！一步一步教你批量发送邮件 - Office中国论坛/Access中国论坛

Sub SandMoreMail()
Dim OutApp As outlook.Application ‘//定义outlook的对象变量
Dim oItem As outlook.MailItem ‘//定义outlook邮件的对象变量
Set OutApp = New outlook.Application ‘//创建outlook对象
For i=1 to 50 ‘//循环体
Set oItem = OutApp.CreateItem(olMailItem) ‘//创建一封新的邮件
With oItem
.To = "l" ‘//邮件收件人自己写入邮箱
.CC = “” ‘//邮件抄送人自己写入邮箱
.Subject = “第” & I & “封邮件发送” ‘//组合邮件的主题内容
.BodyFormat = olFormatHTML ‘//设置邮件格式是否html 格式的
.Attachments.Add "D:" & myatt ‘//添加附件
.Body = “你好！！第” & I & “封邮件发送” ‘//邮主体内容
.Display ‘//新建邮件窗口显示
.send ‘//邮件发送
End With
Next
End Sub

复制代码

Sub hhh()
Dim arr
arr = Array(Array("序号", "主题", "主体", "邮箱"), Array(1, "测试邮件", "你好，测试邮件进行中！！！", "lyhschool@163.com"), Array(2, "测试邮件", "你好，测试邮件进行中！！！", "417149126@qq.com"))
Dim OutApp As Outlook.Application '//定义outlook的对象变量
Dim oItem As Outlook.MailItem '//定义outlook邮件的对象变量
Set OutApp = New Outlook.Application '//创建outlook对象
dim myatt as string
myatt =“D:\5.jpg”
For i = 1 To UBound(arr(0)) - 1
Set oItem = OutApp.CreateItem(olMailItem) '//创建一封新的邮件
With oItem
.To = arr(i)(3) '//邮件收件人
'// .CC = "417149126@qq.com" '//邮件抄送人
.Subject = arr(i)(1) '//邮件的主题
.BodyFormat = olFormatHTML '//设置邮件格式是否html 格式的
'// .Attachments.Add myatt '//添加附件
.Body = arr(i)(2) '//邮主体内容
'// .Display '//新建邮件窗口显示
.Send '//邮件发送
End With
Next
End Sub

复制代码

'*******************************************************************
'程序名称：最完美的利用EXCEL自动批量发送邮件
'
'经测试在OUTLOOK 2000中不会显示警告窗口.
'引用：Microseft Outlook *.0 Object Library
'需要注意一点 , 邮件的标题, 否则不能自动放送!
'**********************************************************************
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)
'设置邮件主题
.Subject = Cells(rowCount, 2)
'设置邮件内容（从通讯录表的'内容'字段中获得）
.Body = Cells(rowCount, 3)
'设置附件（从通讯录表的'附件'字段中获得）
.Attachments.Add Cells(rowCount, 4).value
'自动发送邮件
.Send
End With
'销毁objMail对象
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

复制代码