使用Excel快速发送大量的电子邮件

使⽤Excel快速发送⼤量的电⼦邮件
使⽤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红圈所⽰的绿⾊三⾓按钮，会弹出下图所⽰的对话框。

点运⾏，就开始批量发送邮件了。

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

如果有，恭喜你，收⼯~~
---------------------------------------------------------------------
下⾯讲解
1. 如何发送彩⾊的邮件
2. 如何替换正⽂中的部分内容，例如，每⼀封邮件中可能最开始的称呼不同，给对⽅报出的数字不同等
3. 如何发送多附件
---------------------------------------------------------------------
1.
发送彩⾊邮件需要两步，
第⼀步：上⾯的代码需要改⼀句（红⾊加粗⽂本，body改成HTMLBody）：
‘代码list-2
' 发送单个邮件的⼦程序
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
注意：上⾯“maxReplaceCount = 2"这⼀⾏代码，2需要改成你⾃⼰的值，替换⼏个地⽅就写⼏（新添加了⼏个列就写⼏）上⾯添加了E、F两列，就是2，如果你添加了3处替换（E、F、G列），就写3.
不过，对于需要重复替换的内容，不需要添加新列，例如。

《⼤话西游》在邮件中出现了两次，可以重复使⽤[==2==]来代表。

3. 如何发送多附件
在实际应⽤场景中可能需要发送多封附件。

其实很简单，将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
参考⽂献：
本⽂发送邮件过程中不会弹出安全提⽰框。

发件速度极快；)
⽹友反馈：
发件⼈：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发送到循环逐个。