企业制作工资表利用Exceloutlook批量快速发送电子邮件

1、Excel 和outlook 结合自己制作出可以群发工资的程序，然后通过HTML语言实现排版的表格化。首先是实现EXCLE 中VB 自动调用OUTLOOK 的语句，举一反三。1 .准备通过以下是通过HTML 做的一个表格的部分，具体的数据项则通过VB 来索引实现。效果如下你好=1=,下面是你2月份的<font color="red"><b>工资</b></font>，明细如下：<table align="center" width="500" height="25&quo

2、t; border=1 bordercolor="#000000"><tbody><tr><td colspan="4" align="center"> 工资表 </td></tr><tr><td width="25%" height="25">薪酬等级 </td><td width="25%" height="25">=2= </td&

3、gt;<td width="25%" height="25">稿费、其它 </td><td width="25%" height="25">=3= </td></tr><tr><td width="25%" height="25">薪档 </td><td width="25%" height="25">=4= </td>

4、;<td width="25%" height="25">岗位津贴 </td><td width="25%" height="25">=6= </td></tr><tr><td width="25%" height="25">基本工资 </td><td width="25%" height="25">=4= </td>

5、<td width="25%" height="25">应发合计 </td><td width="25%" height="25">=6= </td></tr><tr><td width="25%" height="25">岗位工资 </td><td width="25%" height="25">=4= </td>&

6、lt;td width="25%" height="25">扣公积金 </td><td width="25%" height="25">=6= </td></tr><tr><td width="25%" height="25">补贴 </td><td width="25%" height="25">=4= </td><

7、td width="25%" height="25">扣统筹保险 </td><td width="25%" height="25">=6= </td></tr><tr><td width="25%" height="25">工龄工资 </td><td width="25%" height="25">=4= </td><

8、td width="25%" height="25">扣医疗保险 </td><td width="25%" height="25">=6= </td></tr><tr><td width="25%" height="25">特补、独子 </td><td width="25%" height="25">=4= </td><

9、;td width="25%" height="25">扣失业保险 </td><td width="25%" height="25">=6= </td></tr><tr><td width="25%" height="25">加班费 </td><td width="25%" height="25">=4= </td><

10、td width="25%" height="25">计税工资 </td><td width="25%" height="25">=6= </td></tr><tr><td width="25%" height="25">事假等扣款 </td><td width="25%" height="25">=4= </td><

11、td width="25%" height="25">扣税金 </td><td width="25%" height="25">=6= </td></tr><tr><td colspan="2" align="center" width="50%" height="25">实发合计 </td><td colspan="2"

12、 align="center" width="50%" height="25">=4= </td></tr></tbody></table>,感谢你的辛勤工作。准备待发送的数据：a.) 打开Excel，新建Book1.xlsxb.) 填入下面的内容，第一列：接收人，第二列：邮件标题，第三列：正文，第四列：附件路径注意：附件路径中可以有中文，但是不能有空格这里你可以写更多内容，每一行作为一封邮件发出。注意：邮件正文是黑白文本内容，不支持加粗、字体颜色等。（如果你需要支持彩色的邮件，后

13、面将会给出解决办法）2. 编写宏发送邮件a.) Alt + F11 打开宏编辑器，菜单中选：插入->模块b.) 将下面的代码粘贴到模块代码编辑器中：代码list-1vb view plaincopyprint?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 Functio

14、n 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 1

15、0. 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) 2

16、0. 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 '收件者

17、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

18、, endRowNo 43. endRowNo = Cells(1, 1). 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 Public Declare Function SetTimer Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEvent As Lo

19、ng, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As LongPublic Declare Function KillTimer Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEvent As Long) As LongPrivate Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Function WinProcA(ByVal hwnd As Long, ByVal uMs

20、g As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long KillTimer 0, idEvent DoEvents Sleep 100 '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了 Application.SendKeys "%s"End Function' 发送单个邮件的子程序Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal

21、 attachement As String) Dim objOL As Object Dim itmNewMail As Object '引用Microsoft Outlook 对象 Set objOL = CreateObject("Outlook.Application") Set itmNewMail = objOL.CreateItem(olMailItem) With itmNewMail .subject = subject '主旨 .body = body '正文本文 .To = to_who '收件者 .Attachment

22、s.Add attachement '附件，如果你不需要发送附件，可以把这一句删掉即可，Excel中的第四列留空，不能删哦 .Display '启动Outlook发送窗口 SetTimer 0, 0, 0, AddressOf WinProcA End With Set objOL = Nothing Set itmNewMail = NothingEnd Sub'批量发送邮件Sub BatchSendMail() Dim rowCount, endRowNo '逐行发送邮件 For rowCount = 1 To endRowNo SendMail Cells

23、(rowCount, 1), Cells(rowCount, 2), Cells(rowCount, 3), Cells(rowCount, 4) NextEnd Sub最终代码编辑器中的效果如下图：i为了正确执行代码，你还需要在菜单中选择： 工具->引用 中的Microseft Outlook X.0 Object Library 勾选上 （X.0是版本号，不同机器可能不一样）c.) 粘贴好代码、勾选上上面的东东后可以发送邮件了，点击上图A红圈所示的绿色三角按钮，会弹出下图所示的对话框，点运行，就开始批量发送邮件了。d.) 如果你想确认你的邮件是否都发出去了，可以去Outlook的“已

24、发送邮件”文件夹中查看，是否有你希望发出的邮件，如果有，恭喜你，收工-下面讲解1. 如何发送彩色的邮件2. 如何替换正文中的部分内容，例如，每一封邮件中可能最开始的称呼不同，给对方报出的数字不同等3. 如何发送多附件-1. 如何发送彩色邮件发送彩色邮件需要两步，第一步：上面的代码需要改一句（红色加粗文本，body改成HTMLBody）：代码list-2vb view plaincopyprint?1. ' 发送单个邮件的子程序 2. Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As S

25、tring, 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

26、 = 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 ' 发送单个邮件的子程序Sub SendMail(ByVal to_who A

27、s String, ByVal subject As String, ByVal body As String, ByVal attachement As String) Dim objOL As Object Dim itmNewMail As Object '引用Microsoft Outlook 对象 Set objOL = CreateObject("Outlook.Application") Set itmNewMail = objOL.CreateItem(olMailItem) With itmNewMail .subject = subject &#

28、39;主旨 ' .HTMLbody = body '正文本文，仅仅这一行跟前面不同，其余都是一样的哦 ' .To = to_who '收件者 .Attachments.Add attachement '附件 .Display '启动Outlook发送窗口 SetTimer 0, 0, 0, AddressOf WinProcA End With Set objOL = Nothing Set itmNewMail = NothingEnd Sub第二步：修改excel第三列（C列）的内容，这需要你懂一点点HTML语言例如，希望在邮件中将“报税单”

29、三个字变红，加粗，则将第三列的内容修改为：您好，下面是这一周的<font color="red"><b>报税单</b></font>，最终效果如图：去发件箱里看看效果吧：注意：在Excel里面编辑正文，进行加粗、加颜色的操作不会生效哦。必须用HTML自己来 2. 如何替换正文部分内容分两步：1. 换Excel内容2. 换代码1. 换Excel内容：将变化的部分用=xxxx=这样的形式替换掉。注意：中间没有空格。例如上图，数字=1=会被E列的内容替换掉，=2=会被F列的内容替换掉，依此类推，如果有更多，就添加更多列，=3=, =

30、4=等等。2. 换代码，将 "批量发送邮件"这一段程序完全替换成下面的代码：vb view plaincopyprint?1. '批量发送邮件 2. Sub BatchSendMail() 3. Dim rowCount, endRowNo 4. Dim newBody 5. Dim replaceCount, maxReplaceCount 6. Dim pattern 7. endRowNo = Cells(1, 1). 8.9. '逐行发送邮件 10. For rowCount = 1 To endRowNo 11. ' 替换当前行模板内容 1

31、2. 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.

32、 Next 19. ' 替换好了，发邮件咯！ 20. SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4) 21.22. Next 23. End Sub '批量发送邮件Sub BatchSendMail() Dim rowCount, endRowNo Dim newBody Dim replaceCount, maxReplaceCount Dim pattern '逐行发送邮件 For rowCount = 1 To endRowNo ' 替换当前行模板内容

33、 maxReplaceCount = 2 ' 有几处替换就写几，例子中有两处，就写2 newBody = Cells(rowCount, 3) For replaceCount = 1 To maxReplaceCount pattern = "=" & CStr(replaceCount) & "=" newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount) Next ' 替换好了，发邮件咯！ Se

34、ndMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4) NextEnd Sub注意：上面“maxReplaceCount = 2"这一行代码，2需要改成你自己的值，替换几个地方就写几（新添加了几个列就写几）上面添加了E、F两列，就是2，如果你添加了3处替换（E、F、G列），就写3.不过，对于需要重复替换的内容，不需要添加新列，例如，大话西游在邮件中出现了两次，可以重复使用=2=来代表。3. 如何发送多附件在实际应用场景中可能需要发送多封附件，其实很简单，将SendMail子程序修改成下面的样

35、子即可：vb view plaincopyprint?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 = CreateOb

36、ject("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 I

37、n 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 ' 发送单个邮件的子程序Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal bo

38、dy As String, ByVal attachement As String) Dim objOL As Object Dim itmNewMail As Object Dim attaches Dim attach '引用Microsoft Outlook 对象 Set objOL = CreateObject("Outlook.Application") Set itmNewMail = objOL.CreateItem(olMailItem) With itmNewMail .subject = subject '主旨 .HTMLbody = b

39、ody '正文本文 .To = to_who '收件者 .Display '启动Outlook发送窗口 attaches = Split(attachement, "") For Each attach In attaches If (Len(attach) > 0) Then .Attachments.Add attach End If Next SetTimer 0, 0, 0, AddressOf WinProcA End With Set objOL = Nothing Set itmNewMail = NothingEnd Sub在E

40、xcel的附件列（第三列），多个附件用半角的分号分隔开（是”;"，不是”；“），例如：c:doc毕业证书附件.jpg;c:doc校方证明书.docx最终代码如下：汇总了批量替换、彩色邮件、多附件功能vb view plaincopyprint?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. Pub

41、lic 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 SysT

42、ime 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 at

43、tachement 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 '

44、;主旨 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

45、. 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). 60.61. '逐行发送邮件 62. For rowCount =

46、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, Ce

47、lls(rowCount, 4 + replaceCount) 70. Next 71. ' 替换好了，发邮件咯！ 72. SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4) 73.74. Next 75. End SubPublic Declare Function SetTimer Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As LongPublic Declare Function KillTimer Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEven