您好，经过測试，该方法对于大量发送邮件（大于100封。几十封没有问题。）有一些问题，由于程序必须在建立完毕全部word发送窗体后，才会统一alt+S发送，非常easy造成内存不足，而且，最后的alt+S便不再运行，在实际应用中，我仅仅能再写一个button，每次发送5封，发送完毕计数+5，手工再点；想跟您请教，能否有更好的改进方法？
标签：
利用Excel批量高速发送电子邮件，分两步：
1. 准备待发送的数据：
a.) 打开Excel，新建Book1.xlsx
b.) 填入以下的内容，
第一列：接收人，第二列：邮件标题，第三列：正文，第四列：附件路径
注意：附件路径中能够有中文，可是不能有空格
这里你能够写很多其它内容，每一行作为一封邮件发出。
注意：邮件正文是黑白文本内容，不支持加粗、字体颜色等。（假设你须要支持彩色的邮件，后面将会给出解决的方法）
2. 编写宏发送邮件
a.) Alt + F11 打开宏编辑器，菜单中选：插入->模块
b.) 将以下的代码粘贴到模块代码编辑器中：
‘代码list-1
Public Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 "%s"
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
‘引用Microsoft Outlook 对象
Set objOL = CreateObject("Outlook.Application")
Set itmNewMail = objOL.CreateItem(olMailItem)
With itmNewMail
.subject = subject ‘主旨
.body = body ‘正文本文
.To = to_who ‘收件者
.Attachments.Add attachement ‘附件，假设你不须要发送附件，能够把这一句删掉就可以，Excel中的第四列留空，不能删哦
.Display ‘启动Outlook发送窗体
SetTimer 0, 0, 0, AddressOf WinProcA
End With
Set objOL = Nothing
Set itmNewMail = Nothing
End Sub
‘批量发送邮件
Sub BatchSendMail()
Dim rowCount, endRowNo
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
‘逐行发送邮件
For rowCount = 1 To endRowNo
SendMail Cells(rowCount, 1), Cells(rowCount, 2), Cells(rowCount, 3), Cells(rowCount, 4)
Next
End Sub
i
为了正确运行代码，你还须要在
菜单中选择： 工具->引用 中的Microseft Outlook X.0 Object Library 勾选上 （X.0是版本，不同机器可能不一样）
c.) 粘贴好代码、勾选上上面的东东后能够发送邮件了，点击上图A红圈所看到的的绿色三角button，会弹出下图所看到的的对话框，点执行，就開始批量发送邮件了。
d.) 假设你想确认你的邮件是否都发出去了，能够去Outlook的“已发送邮件”目录中查看，是否有你希望发出的邮件，假设有，恭喜你，收工~~
---------------------------------------------------------------------
以下解说
1. 怎样发送彩色的邮件
2. 怎样替换正文中的部分内容，比如，每一封邮件中可能最開始的称呼不同，给对方报出的数字不同等
3. 怎样发送多附件
---------------------------------------------------------------------
1. 怎样发送彩色邮件
发送彩色邮件须要两步，
第一步：上面的代码须要改一句（红色加粗文本，body改成HTMLBody）：
‘ 发送单个邮件的子程序
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
‘引用Microsoft Outlook 对象
Set objOL = CreateObject("Outlook.Application")
Set itmNewMail = objOL.CreateItem(olMailItem)
With itmNewMail
.subject = subject ‘主旨
‘~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.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语言
比如，希望在邮件中将“报税单”三个字变红，加粗，则将第三列的内容改动为：
您好，以下是这一周的<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. 换代码，将 "批量发送邮件"这一段程序全然替换成以下的代码：
‘批量发送邮件
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 = "[==" & CStr(replaceCount) & "==]"
newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount))
Next
‘ 替换好了，发邮件咯！
SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4)
Next
End Sub
只是，对于须要反复替换的内容，不须要加入新列，比如，《大话西游》在邮件中出现了两次，能够反复使用[==2==]来代表。
3. 怎样发送多附件
在实际应用场景中可能须要发送多封附件，事实上非常easy，将SendMail子程序改动成以下的样子就可以：
‘ 发送单个邮件的子程序
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("Outlook.Application")
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
在Excel的附件列（第三列），多个附件用半角的分号分隔开（是”;"，不是”；“），比如：
c:\doc\毕业证书附件.jpg;c:\doc\校方证明书.docx
Public Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 "%s"
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("Outlook.Application")
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 = "[==" & CStr(replaceCount) & "==]"
newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount))
Next
‘ 替换好了，发邮件咯！
SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4)
Next
End Sub
參考文献：
本文发送邮件过程中不会弹出安全提示框，发件速度极快；)
网友反馈：
您好，经过測试，该方法对于大量发送邮件（大于100封。几十封没有问题。）有一些问题，由于程序必须在建立完毕全部word发送窗体后，才会统一alt+S发送，非常easy造成内存不足，而且，最后的alt+S便不再运行，在实际应用中，我仅仅能再写一个button，每次发送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上。假设你知道公司的邮件server的pop3地址，最好还是用命令行工具来实现邮件的批量自己主动发送。
比如：Blat：http://www.blat.net/syntax/syntax.html
先用随意工具将一封封的邮件准备好，保存为一个个文本文件，然后用Blat逐个循环发送就可以。
标签：
原文地址：http://www.cnblogs.com/lcchuguo/p/4482982.html
