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

funsz

整个代码如下：

1. Function GetBoiler(ByVal sFile As String) As String
   
2.     Dim fso As Object
   
3.     Dim ts As Object
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
   
6.     GetBoiler = ts.readall
   
7.     ts.Close
   
8. End Function
   
9. Sub sendmail()
   
10. 
    
11. '先通过VBA窗口"工具"菜单--"引用"选择 "Microsoft outlook 11.0 object Library
    
12. '已在Outlook中设置可发送邮件的正常帐号
    
13. 
    
14. On Error Resume Next
    
15. Dim rowCount, endRowNo
    
16. 
    
17. Dim objOutlook As New Outlook.Application
    
18. Dim objMail As MailItem
    
19. 
    
20. Dim strbody As String
    
21. Dim SigString As String
    
22. Dim Signature As String
    
23. 
    
24. '统计Excel中的行数
    
25. 
    
26. endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
    
27. 
    
28. '"创建objO为Outlook应用程序对象
    
29. 
    
30. Set objO = New Outlook.Application
    
31. 
    
32. '"循环发送电子邮件,第1行是表格头,所以从第2行开始
    
33. '"创建objMail为一个邮件对象
    
34. '"设置收件人地址(以下邮件的信息皆从EXCEL工件表的字段中获得)
    
35. '"设置邮件主题
    
36. 
    
37. For rowCount = 2 To endRowNo
    
38. 
    
39.    Set objMail = objOutlook.CreateItem(olMailItem)
    
40.    
    
41.     strbody = "<H3><B>DEAR ALL,</B></H3>" & _
    
42.               "此附件为" & _
    
43.               "<B>" & _
    
44.               Cells(rowCount, 4) & _
    
45.               "</B>" & _
    
46.               "，文件已寄出，请注意查收。<br>" & _
    
47.               "邮件是批量发送的，如没有附件，则没有文件寄送，请知悉。<br>" & _
    
48.               "如有其它问题，请及时反馈。<br>" & _
    
49.               "<br>谢谢!"
    
50.               
    
51.     SigString = Environ("appdata") & _
    
52.      "\Microsoft\Signatures\(请填写你签名的名字）.htm"
    
53.      
    
54.     If Dir(SigString) <> "" Then
    
55.         Signature = GetBoiler(SigString)
    
56.     Else
    
57.         Signature = ""
    
58.     End If
    
59. 
    
60.    With objMail
    
61.      .To = Cells(rowCount, 1)
    
62.      .CC = Cells(rowCount, 2)
    
63.      .Subject = Cells(rowCount, 3)
    
64.      '.Body = Cells(rowCount, 4)
    
65.      .HTMLBody = strbody & "<br><br>" & Signature
    
66. 
    
67.    '"设置附件(从通讯录表的“附件”字段中获得)
    
68.     For i = 5 To 8
    
69.      If Sheets("Sheet1").Cells(rowCount, i).Value <> "" Then
    
70.         fj = "'" + Cells(rowCount, i) + "'" / 为字符串字段加上引号
    
71.         MsgBox fj / 是了看一下附件字段的字符串内容对不对
    
72.         .Display
    
73.         .Attachments.Add Sheets("Sheet1").Cells(rowCount, i).Value
    
74.      End If
    
75.     Next i
    
76. '发送附件一直不成功,只有当.Attachments.Add "d:\aa.doc"可以成功,一旦使用了EXCEL表格中的字段时,想让每个人接收
    
77. '的附件不一样,这时用了下面二种方法都不成功,也试着在附件字段中加引号了,如 d:\aa.txt,改为"d:\aa.txt"
    
78. '.Attachments.Add("'" + Cells(rowCount, 4) + "'")
    
79. '.Attachments.Add(Cells(rowCount, 4))
    
80. '发送邮件
    
81.     If .Attachments.Count > 0 Then .Send
    
82.    End With
    
83.    Set objMail = Nothing
    
84. Next
    
85. Set objOutlook = Nothing
    
86. End Sub

复制代码

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

复制代码

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

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

复制代码

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

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

复制代码

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

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

复制代码

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

1.     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, 下载次数: 234)

2015-3-27 12:33 上传

点击文件名下载附件

funsz

如有没附件的话，可以把

1. If .Attachments.Count > 0 Then .Send

复制代码

上面这句代码稍微改下

1. If .Attachments.Count > 0 Then
   
2. .Send
   
3. Else
   
4. 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)

2015-10-15 10:46 上传

点击文件名下载附件

funsz

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

funsz

引用的

excelhomehuawei

挺 有用，谢谢分享

funsz

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

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

huachixt

Module not found ..怎么办呀