利用Excel批量快速发送电子邮件

   

       
        利用Excel批量快速发送电子邮件
       
   

   

       
        分类：
            应用开发
       
    2012-10-31 20:51
    4513人阅读
    评论(8)
    收藏
    举报
   

   

目录(?)[+]

利用Excel批量快速发送电子邮件，分两步：

1. 准备待发送的数据：

   a.) 打开Excel，新建Book1.xlsx

   b.) 填入下面的内容，

第一列：接收人，第二列：邮件标题，第三列：正文，第四列：附件路径

注意：附件路径中可以有中文，但是不能有空格

这里你可以写更多内容，每一行作为一封邮件发出。

注意：邮件正文是黑白文本内容，不支持加粗、字体颜色等。（如果你需要支持彩色的邮件，后面将会给出解决办法）

2. 编写宏发送邮件

  a.) Alt + F11 打开宏编辑器，菜单中选：插入->模块

  b.) 将下面的代码粘贴到模块代码编辑器中：

‘代码list-1

[vb] view plaincopy

1. Public Declare Function SetTimer Lib "user32" _  
2.         (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long  
3. Public Declare Function KillTimer Lib "user32" _  
4.         (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long  
5. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)  
6.   
7.   
8.   
9. Function WinProcA(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long  
10.     KillTimer 0, idEvent  
11.     DoEvents  
12.     Sleep 100  
13.     '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了  
14.     Application.SendKeys "%s"  
15. End Function  
16.   
17.   
18. ' 发送单个邮件的子程序  
19. Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String)  
20.     Dim objOL As Object  
21.     Dim itmNewMail As Object  
22.     '引用Microsoft Outlook 对象  
23.     Set objOL = CreateObject("Outlook.Application")  
24.     Set itmNewMail = objOL.CreateItem(olMailItem)  
25.     With itmNewMail  
26.         .subject = subject  '主旨  
27.         .body = body   '正文本文  
28.         .To = to_who  '收件者  
29.         .Attachments.Add attachement '附件，如果你不需要发送附件，可以把这一句删掉即可，Excel中的第四列留空，不能删哦  
30.         .Display  '启动Outlook发送窗口  
31.         SetTimer 0, 0, 0, AddressOf WinProcA  
32.     End With  
33.     Set objOL = Nothing  
34.     Set itmNewMail = Nothing  
35. End Sub  
36.   
37.   
38.   
39.   
40. '批量发送邮件  
41. Sub BatchSendMail()  
42.     Dim rowCount, endRowNo  
43.     endRowNo = Cells(1, 1).CurrentRegion.Rows.Count  
44.     '逐行发送邮件  
45.     For rowCount = 1 To endRowNo  
46.         SendMail Cells(rowCount, 1), Cells(rowCount, 2), Cells(rowCount, 3), Cells(rowCount, 4)  
47.     Next  
48. End Sub  

最终代码编辑器中的效果如下图：

i

为了正确执行代码，你还需要在

菜单中选择： 工具->引用 中的Microseft Outlook X.0 Object Library  勾选上 （X.0是版本号，不同机器可能不一样）

   c.) 粘贴好代码、勾选上上面的东东后可以发送邮件了，点击上图A红圈所示的绿色三角按钮，会弹出下图所示的对话框，点运行，就开始批量发送邮件了。

   d.) 如果你想确认你的邮件是否都发出去了，可以去Outlook的“已发送邮件”文件夹中查看，是否有你希望发出的邮件，如果有，恭喜你，收工~~

---------------------------------------------------------------------

下面讲解

1. 如何发送彩色的邮件

2. 如何替换正文中的部分内容，例如，每一封邮件中可能最开始的称呼不同，给对方报出的数字不同等

3. 如何发送多附件

---------------------------------------------------------------------

1. 如何发送彩色邮件

发送彩色邮件需要两步，

第一步：上面的代码需要改一句（红色加粗文本，body改成HTMLBody）：

‘代码list-2

[vb] view plaincopy

1. ' 发送单个邮件的子程序  
2. Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String)  
3.     Dim objOL As Object  
4.     Dim itmNewMail As Object  
5.     '引用Microsoft Outlook 对象  
6.     Set objOL = CreateObject("Outlook.Application")  
7.     Set itmNewMail = objOL.CreateItem(olMailItem)  
8.     With itmNewMail  
9.         .subject = subject  '主旨  
10.         '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
11.          .HTMLbody = body   '正文本文，仅仅这一行跟前面不同，其余都是一样的哦~  
12.                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
13.         .To = to_who  '收件者  
14.         .Attachments.Add attachement '附件  
15.         .Display  '启动Outlook发送窗口  
16.         SetTimer 0, 0, 0, AddressOf WinProcA    
17.   End With    Set objOL = Nothing  
18.     Set itmNewMail = NothingEnd Sub  

第二步：修改excel第三列（C列）的内容，这需要你懂一点点HTML语言

例如，希望在邮件中将“报税单”三个字变红，加粗，则将第三列的内容修改为：

您好，下面是这一周的<font color="red"><b>报税单</b></font>，…

最终效果如图：

去发件箱里看看效果吧：

注意：在Excel里面编辑正文，进行加粗、加颜色的操作不会生效哦。必须用HTML自己来，sorry哦 不会HTML的朋友可以新浪微博follow我帮忙：@研究员Raywill

2. 如何替换正文部分内容

分两步：

1. 换Excel内容

2. 换代码

1. 换Excel内容：

将变化的部分用[==xxxx==]这样的形式替换掉。注意：中间没有空格。

例如上图，数字[==1==]会被E列的内容替换掉，[==2==]会被F列的内容替换掉，依此类推，如果有更多，就添加更多列，[==3==], [==4==]等等。

2. 换代码，将 "批量发送邮件"这一段程序完全替换成下面的代码：

[vb] view plaincopy

1. '批量发送邮件  
2. Sub BatchSendMail()  
3.     Dim rowCount, endRowNo  
4.     Dim newBody  
5.     Dim replaceCount, maxReplaceCount  
6.     Dim pattern  
7.     endRowNo = Cells(1, 1).CurrentRegion.Rows.Count  
8.       
9.     '逐行发送邮件  
10.     For rowCount = 1 To endRowNo  
11.         ' 替换当前行模板内容  
12.         maxReplaceCount = 2   ' 有几处替换就写几，例子中有两处，就写2  
13.         newBody = Cells(rowCount, 3)  
14.   
15.         For replaceCount = 1 To maxReplaceCount  
16.             pattern = "[==" & CStr(replaceCount) & "==]"  
17.             newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount))  
18.         Next  
19.         ' 替换好了，发邮件咯！  
20.         SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4)  
21.           
22.     Next  
23. End Sub  

注意：上面“maxReplaceCount = 2"这一行代码，2需要改成你自己的值，替换几个地方就写几（新添加了几个列就写几）上面添加了E、F两列，就是2，如果你添加了3处替换（E、F、G列），就写3.

不过，对于需要重复替换的内容，不需要添加新列，例如，《大话西游》在邮件中出现了两次，可以重复使用[==2==]来代表。

3. 如何发送多附件

在实际应用场景中可能需要发送多封附件，其实很简单，将SendMail子程序修改成下面的样子即可：

[vb] view plaincopy

1. ' 发送单个邮件的子程序  
2. Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String)  
3.     Dim objOL As Object  
4.     Dim itmNewMail As Object  
5.     Dim attaches  
6.     Dim attach  
7.       
8.     '引用Microsoft Outlook 对象  
9.     Set objOL = CreateObject("Outlook.Application")  
10.     Set itmNewMail = objOL.CreateItem(olMailItem)  
11.     With itmNewMail  
12.         .subject = subject  '主旨  
13.         .HTMLbody = body   '正文本文  
14.         .To = to_who  '收件者  
15.         .Display  '启动Outlook发送窗口  
16.         attaches = Split(attachement, ";")  
17.           
18.         For Each attach In attaches  
19.             If (Len(attach) > 0) Then  
20.                 .Attachments.Add attach  
21.             End If  
22.         Next  
23.         SetTimer 0, 0, 0, AddressOf WinProcA  
24.     End With  
25.       
26.     Set objOL = Nothing  
27.     Set itmNewMail = Nothing  
28. End Sub  

在Excel的附件列（第三列），多个附件用半角的分号分隔开（是”;"，不是”；“），例如：

c:\doc\毕业证书附件.jpg;c:\doc\校方证明书.docx

最终代码如下：

汇总了批量替换、彩色邮件、多附件功能

[vb] view plaincopy

1. Public Declare Function SetTimer Lib "user32" _  
2.         (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long  
3. Public Declare Function KillTimer Lib "user32" _  
4.         (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long  
5. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)  
6.   
7.   
8.   
9.   
10. Function WinProcA(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long  
11.     KillTimer 0, idEvent  
12.     DoEvents  
13.     Sleep 100  
14.     '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了  
15.     Application.SendKeys "%s"  
16. End Function  
17.   
18.   
19. ' 发送单个邮件的子程序  
20. Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String)  
21.     Dim objOL As Object  
22.     Dim itmNewMail As Object  
23.     Dim attaches  
24.     Dim attach  
25.       
26.     '引用Microsoft Outlook 对象  
27.     Set objOL = CreateObject("Outlook.Application")  
28.     Set itmNewMail = objOL.CreateItem(olMailItem)  
29.     With itmNewMail  
30.         .subject = subject  '主旨  
31.         .HTMLbody = body   '正文本文  
32.         .To = to_who  '收件者  
33.         .Display  '启动Outlook发送窗口  
34.         attaches = Split(attachement, ";")  
35.           
36.         For Each attach In attaches  
37.             If (Len(attach) > 0) Then  
38.                 .Attachments.Add attach  
39.             End If  
40.         Next  
41.         SetTimer 0, 0, 0, AddressOf WinProcA  
42.     End With  
43.       
44.   
45.   
46.   
47.     Set objOL = Nothing  
48.     Set itmNewMail = Nothing  
49. End Sub  
50.   
51.   
52.   
53. '批量发送邮件  
54. Sub BatchSendMail()  
55.     Dim rowCount, endRowNo  
56.     Dim newBody  
57.     Dim replaceCount, maxReplaceCount  
58.     Dim pattern  
59.     endRowNo = Cells(1, 1).CurrentRegion.Rows.Count  
60.       
61.     '逐行发送邮件  
62.     For rowCount = 1 To endRowNo  
63.         ' 替换当前行模板内容  
64.         maxReplaceCount = 2   ' 有几处替换就写几，例子中有两处，就写2  
65.         newBody = Cells(rowCount, 3)  
66.   
67.         For replaceCount = 1 To maxReplaceCount  
68.             pattern = "[==" & CStr(replaceCount) & "==]"  
69.             newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount))  
70.         Next  
71.         ' 替换好了，发邮件咯！  
72.         SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4)  
73.           
74.     Next  
75. End Sub  

参考文献：

http://www./cdb/viewthread.php?tid=53888

本文发送邮件过程中不会弹出安全提示框，发件速度极快；)

网友反馈：

• 
  发件人：angel3814
• 
  时间：2013-01-28 10:35:30

您好，经过测试，该方法对于大量发送邮件（大于100封。几十封没有问题。）有一些问题，因为程序必须在建立完成所有word发送窗口后，才会统一alt+S发送，很容易造成内存不足，并且，最后的alt+S便不再执行，在实际应用中，我只能再写一个按钮，每次发送5封，发送完成计数+5，手工再点；想跟您请教，是否能有更好的改进方法？

非常感谢angel3814提供的解决方案：

[vb] view plaincopy

1. Sub BatchSendMail()  
2.     Dim rowCount, endRowNo, csheet As Worksheet, ssheet As Worksheet, i As Integer, j As Integer  
3.     endRowNo = Cells(1, 1).CurrentRegion.Rows.Count  
4.     '逐行发送邮件  
5.     Set csheet = Worksheets("邮件内容")  
6.     Set ssheet = Worksheets("发送")  
7.     i = ssheet.Cells(2, 1).Value  
8.     j = ssheet.Cells(2, 2).Value  
9.       
10.     For rowCount = i To j  
11.         SendMail csheet.Cells(rowCount, 1), csheet.Cells(rowCount, 2), csheet.Cells(rowCount, 3), csheet.Cells(rowCount, 4)  
12.     Next  
13.     ssheet.Cells(2, 1).Value = i + 5  
14.     ssheet.Cells(2, 2).Value = j + 5  
15. End Sub  

点一次，自动+5，再点

之所以用5，是测试发现，10以上，就有很大几率alt+S事件不生效（可能还是延迟问题？）

====

另外，对于希望批量发送邮件的同学，可以不用把思维局限在Outlook上。如果你知道公司的邮件服务器的pop3地址，不妨用命令行工具来实现邮件的批量自动发送。

例如：Blat：http://www./syntax/syntax.html

先用任意工具将一封封的邮件准备好，保存为一个个文本文件，然后用Blat逐个循环发送即可。