VBA通过OUTLOOK批量发邮件（自己研究了下）

funsz · 发表于 2015-3-27 12:34

整个代码如下：

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sub sendmail()
'先通过VBA窗口"工具"菜单--"引用"选择 "Microsoft outlook 11.0 object Library
'已在Outlook中设置可发送邮件的正常帐号
On Error Resume Next
Dim rowCount, endRowNo
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
Dim strbody As String
Dim SigString As String
Dim Signature As String
'统计Excel中的行数
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
'"创建objO为Outlook应用程序对象
Set objO = New Outlook.Application
'"循环发送电子邮件,第1行是表格头,所以从第2行开始
'"创建objMail为一个邮件对象
'"设置收件人地址(以下邮件的信息皆从EXCEL工件表的字段中获得)
'"设置邮件主题
For rowCount = 2 To endRowNo
Set objMail = objOutlook.CreateItem(olMailItem)
strbody = "<H3><B>DEAR ALL,</B></H3>" & _
"此附件为" & _
"<B>" & _
Cells(rowCount, 4) & _
"</B>" & _
"，文件已寄出，请注意查收。<br>" & _
"邮件是批量发送的，如没有附件，则没有文件寄送，请知悉。<br>" & _
"如有其它问题，请及时反馈。<br>" & _
"<br>谢谢!"
SigString = Environ("appdata") & _
"\Microsoft\Signatures\(请填写你签名的名字）.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
With objMail
.To = Cells(rowCount, 1)
.CC = Cells(rowCount, 2)
.Subject = Cells(rowCount, 3)
'.Body = Cells(rowCount, 4)
.HTMLBody = strbody & "<br><br>" & Signature
'"设置附件(从通讯录表的“附件”字段中获得)
For i = 5 To 8
If Sheets("Sheet1").Cells(rowCount, i).Value <> "" Then
fj = "'" + Cells(rowCount, i) + "'" / 为字符串字段加上引号
MsgBox fj / 是了看一下附件字段的字符串内容对不对
.Display
.Attachments.Add Sheets("Sheet1").Cells(rowCount, i).Value
End If
Next i
'发送附件一直不成功,只有当.Attachments.Add "d:\aa.doc"可以成功,一旦使用了EXCEL表格中的字段时,想让每个人接收
'的附件不一样,这时用了下面二种方法都不成功,也试着在附件字段中加引号了,如 d:\aa.txt,改为"d:\aa.txt"
'.Attachments.Add("'" + Cells(rowCount, 4) + "'")
'.Attachments.Add(Cells(rowCount, 4))
'发送邮件
If .Attachments.Count > 0 Then .Send
End With
Set objMail = Nothing
Next
Set objOutlook = Nothing
End Sub

复制代码

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

复制代码

这段代码是用来引用签名，大概是吧，菜鸟不太懂

strbody = "<H3><B>DEAR ALL,</B></H3>" & _

复制代码

Cells(rowCount, 4) 是表格第4列，可以插入在正文

SigString = Environ("appdata") & _
"\Microsoft\Signatures\(请填写你签名的名字）.htm"

复制代码

【(请填写你签名的名字）】请填写你OUTLOOK的签名的名称

For i = 5 To 8
If Sheets("Sheet1").Cells(rowCount, i).Value <> "" Then
fj = "'" + Cells(rowCount, i) + "'" / 为字符串字段加上引号
MsgBox fj / 是了看一下附件字段的字符串内容对不对
.Display
.Attachments.Add Sheets("Sheet1").Cells(rowCount, i).Value
End If
Next i

复制代码

此段代码，是添加附件的代码，可以根据实际情况修改，但是没做到，某个文件夹下所有文件作为附件发送，如果谁能修改，那就更好了

If .Attachments.Count > 0 Then .Send

复制代码

这是判断是否有附件，有就发送，但是至今没做到，没附件自动关闭邮件窗口，每次批量发完还要手动关闭没法邮件，这个也可以优化下
如果是纯文字的邮件，就把If .Attachments.Count > 0 Then删除即可，正文内容多的话，建议使用.Body = Cells(rowCount, 4)，代码注释掉了，可以放弃签名

分享下我修改的
还有大家可以去http://club.excelhome.net/thread-904203-1-1.html，此贴3楼观摩下，要有图片的签名，需要修改些数据谢谢

邮件批量发送.rar (17.97 KB, 下载次数: 236)

funsz · 发表于 2015-10-14 19:32

本帖最后由 funsz 于 2015-10-15 10:48 编辑

如有没附件的话，可以把

If .Attachments.Count > 0 Then .Send

复制代码

上面这句代码稍微改下

If .Attachments.Count > 0 Then
.Send
Else
sendkeys "%{F4}N"

复制代码

sendkeys那段应该是那样吧，可以百度下，就是类型，没有附件的，ALT+F4以下，然后OUTLOOK弹出提示框，用N来选择否按钮。
那个邮件正文可以用HTML语言编辑，一般的有[font color="balck" face="微软雅黑" size="3"]，这句是字体颜色黑色、字体微软雅黑、字体大小3（HTML字体一般大小1-7，自己可以设置下适合的大小），还有就是<br>=shift+enter,<p>=enter，<b></b>加粗，如果要对某几个字设置底纹，可以用<strong style="background:yellow">底纹为黄色，还有就是可以在正文添加图片，<img src="路径">，大概这些是新掌握的，还有的话，我觉得路径的可以使用相对路径会比绝对路径要好修改的附件如下

群发带附件邮件.rar (27.9 KB, 下载次数: 137)

funsz · 发表于 2015-3-27 12:35

沙发自己坐，在论坛找了这么多好帖子，自己改的，发下，慢慢研究出来的

funsz · 发表于 2015-3-27 12:56

引用的

excelhomehuawei · 发表于 2015-4-20 22:02

挺有用，谢谢分享

funsz · 发表于 2015-4-22 13:30

excelhomehuawei 发表于 2015-4-20 22:02
挺有用，谢谢分享

我也是自己从这个网站整合的，加上点自己的研究，对于批量发邮件还是不错的，我自己现在也一直在用

huachixt · 发表于 2020-4-26 15:35

Module not found ..怎么办呀

		自动登录	找回密码
密码			免费注册

[讨论] VBA通过OUTLOOK批量发邮件（自己研究了下）