利用Excel批量快速發(fā)送電子郵件，分兩步：
1. 準(zhǔn)備待發(fā)送的數(shù)據(jù)：
a.) 打開(kāi)Excel，新建Book1.xlsx
b.) 填入下面的內(nèi)容，
第一列：接收人，第二列：郵件標(biāo)題，第三列：正文，第四列：附件路徑
注意：附件路徑中可以有中文，但是不能有空格
這里你可以寫更多內(nèi)容，每一行作為一封郵件發(fā)出。
注意：郵件正文是黑白文本內(nèi)容，不支持加粗、字體顏色等。（如果你需要支持彩色的郵件，后面將會(huì)給出解決辦法）
2. 編寫宏發(fā)送郵件
a.) Alt + F11 打開(kāi)宏編輯器，菜單中選：插入->模塊
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發(fā)送郵件，這是本文的關(guān)鍵之處，免安全提示自動(dòng)發(fā)送郵件全靠它了
- Application.SendKeys "%s"
- End Function
-
-
- ' 發(fā)送單個(gè)郵件的子程序
- 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 對(duì)象
- Set objOL = CreateObject("Outlook.Application")
- Set itmNewMail = objOL.CreateItem(olMailItem)
- With itmNewMail
- .subject = subject '主旨
- .body = body '正文本文
- .To = to_who '收件者
- .Attachments.Add attachement '附件，如果你不需要發(fā)送附件，可以把這一句刪掉即可，Excel中的第四列留空，不能刪哦
- .Display '啟動(dòng)Outlook發(fā)送窗口
- SetTimer 0, 0, 0, AddressOf WinProcA
- End With
- Set objOL = Nothing
- Set itmNewMail = Nothing
- End Sub
-
-
-
-
- '批量發(fā)送郵件
- Sub BatchSendMail()
- Dim rowCount, endRowNo
- endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
- '逐行發(fā)送郵件
- For rowCount = 1 To endRowNo
- SendMail Cells(rowCount, 1), Cells(rowCount, 2), Cells(rowCount, 3), Cells(rowCount, 4)
- Next
- End Sub
最終代碼編輯器中的效果如下圖：
i
為了正確執(zhí)行代碼，你還需要在
菜單中選擇： 工具->引用 中的Microseft Outlook X.0 Object Library 勾選上 （X.0是版本號(hào)，不同機(jī)器可能不一樣）
c.) 粘貼好代碼、勾選上上面的東東后可以發(fā)送郵件了，點(diǎn)擊上圖A紅圈所示的綠色三角按鈕，會(huì)彈出下圖所示的對(duì)話框，點(diǎn)運(yùn)行，就開(kāi)始批量發(fā)送郵件了。
d.) 如果你想確認(rèn)你的郵件是否都發(fā)出去了，可以去Outlook的“已發(fā)送郵件”文件夾中查看，是否有你希望發(fā)出的郵件，如果有，恭喜你，收工~~
---------------------------------------------------------------------
下面講解
1. 如何發(fā)送彩色的郵件
2. 如何替換正文中的部分內(nèi)容，例如，每一封郵件中可能最開(kāi)始的稱呼不同，給對(duì)方報(bào)出的數(shù)字不同等
3. 如何發(fā)送多附件
---------------------------------------------------------------------
1. 如何發(fā)送彩色郵件
發(fā)送彩色郵件需要兩步，
第一步：上面的代碼需要改一句（紅色加粗文本，body改成HTMLBody）：
‘代碼list-2
- ' 發(fā)送單個(gè)郵件的子程序
- 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 對(duì)象
- Set objOL = CreateObject("Outlook.Application")
- Set itmNewMail = objOL.CreateItem(olMailItem)
- With itmNewMail
- .subject = subject '主旨
- '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- .HTMLbody = body '正文本文，僅僅這一行跟前面不同，其余都是一樣的哦~
- '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- .To = to_who '收件者
- .Attachments.Add attachement '附件
- .Display '啟動(dòng)Outlook發(fā)送窗口
- SetTimer 0, 0, 0, AddressOf WinProcA
- End With Set objOL = Nothing
- Set itmNewMail = NothingEnd Sub
第二步：修改excel第三列（C列）的內(nèi)容，這需要你懂一點(diǎn)點(diǎn)HTML語(yǔ)言
例如，希望在郵件中將“報(bào)稅單”三個(gè)字變紅，加粗，則將第三列的內(nèi)容修改為：
您好，下面是這一周的<font color="red"><b>報(bào)稅單</b></font>，…
最終效果如圖：
去發(fā)件箱里看看效果吧：
注意：在Excel里面編輯正文，進(jìn)行加粗、加顏色的操作不會(huì)生效哦。必須用HTML自己來(lái)，sorry哦 不會(huì)HTML的朋友可以新浪微博follow我?guī)兔Γ篅研究員Raywill
2. 如何替換正文部分內(nèi)容
分兩步：
1. 換Excel內(nèi)容
2. 換代碼
1. 換Excel內(nèi)容：
將變化的部分用[==xxxx==]這樣的形式替換掉。注意：中間沒(méi)有空格。
例如上圖，數(shù)字[==1==]會(huì)被E列的內(nèi)容替換掉，[==2==]會(huì)被F列的內(nèi)容替換掉，依此類推，如果有更多，就添加更多列，[==3==], [==4==]等等。
2. 換代碼，將 "批量發(fā)送郵件"這一段程序完全替換成下面的代碼：
- '批量發(fā)送郵件
- Sub BatchSendMail()
- Dim rowCount, endRowNo
- Dim newBody
- Dim replaceCount, maxReplaceCount
- Dim pattern
- endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
-
- '逐行發(fā)送郵件
- For rowCount = 1 To endRowNo
- ' 替換當(dāng)前行模板內(nèi)容
- 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
- ' 替換好了，發(fā)郵件咯！
- SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4)
-
- Next
- End Sub
不過(guò)，對(duì)于需要重復(fù)替換的內(nèi)容，不需要添加新列，例如，《大話西游》在郵件中出現(xiàn)了兩次，可以重復(fù)使用[==2==]來(lái)代表。
3. 如何發(fā)送多附件
在實(shí)際應(yīng)用場(chǎng)景中可能需要發(fā)送多封附件，其實(shí)很簡(jiǎn)單，將SendMail子程序修改成下面的樣子即可：
- ' 發(fā)送單個(gè)郵件的子程序
- 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 對(duì)象
- Set objOL = CreateObject("Outlook.Application")
- Set itmNewMail = objOL.CreateItem(olMailItem)
- With itmNewMail
- .subject = subject '主旨
- .HTMLbody = body '正文本文
- .To = to_who '收件者
- .Display '啟動(dòng)Outlook發(fā)送窗口
- 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的附件列（第三列），多個(gè)附件用半角的分號(hào)分隔開(kāi)（是”;"，不是”；“），例如：
c:\doc\畢業(yè)證書(shū)附件.jpg;c:\doc\校方證明書(shū).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發(fā)送郵件，這是本文的關(guān)鍵之處，免安全提示自動(dòng)發(fā)送郵件全靠它了
- Application.SendKeys "%s"
- End Function
-
-
- ' 發(fā)送單個(gè)郵件的子程序
- 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 對(duì)象
- Set objOL = CreateObject("Outlook.Application")
- Set itmNewMail = objOL.CreateItem(olMailItem)
- With itmNewMail
- .subject = subject '主旨
- .HTMLbody = body '正文本文
- .To = to_who '收件者
- .Display '啟動(dòng)Outlook發(fā)送窗口
- 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
-
-
-
- '批量發(fā)送郵件
- Sub BatchSendMail()
- Dim rowCount, endRowNo
- Dim newBody
- Dim replaceCount, maxReplaceCount
- Dim pattern
- endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
-
- '逐行發(fā)送郵件
- For rowCount = 1 To endRowNo
- ' 替換當(dāng)前行模板內(nèi)容
- 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
- ' 替換好了，發(fā)郵件咯！
- SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4)
-
- Next
- End Sub
參考文獻(xiàn)：
http://www.officefans.net/cdb/viewthread.php?tid=53888
本文發(fā)送郵件過(guò)程中不會(huì)彈出安全提示框，發(fā)件速度極快；)
網(wǎng)友反饋：
發(fā)件人：angel3814
時(shí)間：2013-01-28 10:35:30
您好，經(jīng)過(guò)測(cè)試，該方法對(duì)于大量發(fā)送郵件（大于100封。幾十封沒(méi)有問(wèn)題。）有一些問(wèn)題，因?yàn)槌绦虮仨氃诮⑼瓿伤衱ord發(fā)送窗口后，才會(huì)統(tǒng)一alt+S發(fā)送，很容易造成內(nèi)存不足，并且，最后的alt+S便不再執(zhí)行，在實(shí)際應(yīng)用中，我只能再寫一個(gè)按鈕，每次發(fā)送5封，發(fā)送完成計(jì)數(shù)+5，手工再點(diǎn)；想跟您請(qǐng)教，是否能有更好的改進(jìn)方法？
非常感謝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
- '逐行發(fā)送郵件
- Set csheet = Worksheets("郵件內(nèi)容")
- Set ssheet = Worksheets("發(fā)送")
- 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
點(diǎn)一次，自動(dòng)+5，再點(diǎn)
之所以用5，是測(cè)試發(fā)現(xiàn)，10以上，就有很大幾率alt+S事件不生效（可能還是延遲問(wèn)題？）
====
另外，對(duì)于希望批量發(fā)送郵件的同學(xué)，可以不用把思維局限在Outlook上。如果你知道公司的郵件服務(wù)器的pop3地址，不妨用命令行工具來(lái)實(shí)現(xiàn)郵件的批量自動(dòng)發(fā)送。
例如：Blat：http://www.blat.net/syntax/syntax.html
先用任意工具將一封封的郵件準(zhǔn)備好，保存為一個(gè)個(gè)文本文件，然后用Blat逐個(gè)循環(huán)發(fā)送即可。
