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

End With

Set objOL = Nothing Set itmNewMail = Nothing End Sub

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

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

最终代码如下：

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

Public Declare Function SetTimer Lib \

(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long

Public Declare Function KillTimer Lib \

(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Private Declare Sub Sleep Lib \

Function WinProcA(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long KillTimer 0, idEvent DoEvents Sleep 100

'使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了

Application.SendKeys \End Function

' 发送单个邮件的子程序

Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String) Dim objOL As Object Dim itmNewMail As Object Dim attaches Dim attach

'引用Microsoft Outlook 对象

Set objOL = CreateObject(\ Set itmNewMail = objOL.CreateItem(olMailItem) With itmNewMail

.subject = subject '主旨 .HTMLbody = body '正文本文 .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 = Nothing End Sub

'批量发送邮件 Sub BatchSendMail() Dim rowCount, endRowNo Dim newBody

Dim replaceCount, maxReplaceCount Dim pattern

endRowNo = Cells(1, 1).CurrentRegion.Rows.Count

'逐行发送邮件

For rowCount = 1 To endRowNo ' 替换当前行模板内容

maxReplaceCount = 2 ' 有几处替换就写几，例子中有两处，就写2 newBody = Cells(rowCount, 3)

For replaceCount = 1 To maxReplaceCount

pattern = \

newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount)) Next

' 替换好了，发邮件咯！

SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4)

Next End Sub

参考文献：

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

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

网友反馈：

? ?

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

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

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

Sub BatchSendMail()

Dim rowCount, endRowNo, csheet As Worksheet, ssheet As Worksheet, i As Integer, j As Integer

endRowNo = Cells(1, 1).CurrentRegion.Rows.Count '逐行发送邮件

Set csheet = Worksheets(\邮件内容\ Set ssheet = Worksheets(\发送\ i = ssheet.Cells(2, 1).Value j = ssheet.Cells(2, 2).Value

For rowCount = i To j

SendMail csheet.Cells(rowCount, 1), csheet.Cells(rowCount, 2), csheet.Cells(rowCount, 3), csheet.Cells(rowCount, 4) Next

ssheet.Cells(2, 1).Value = i + 5 ssheet.Cells(2, 2).Value = j + 5 End Sub

点一次，自动+5，再点

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

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

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

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

版权声明：本文为博主原创文章，未经博主允许不得转载。 ? ?

上一篇OceanBase Join操作

下一篇对比MessagePack和Protocal Buffer