利用Excel批量快速發(fā)送電子郵件

1、利用Excel批量快速發(fā)送電子郵件，分兩步：1. 準備待發(fā)送的數(shù)據(jù)：   a.) 打開Excel，新建Book1.xlsx   b.) 填入下面的內(nèi)容，第一列：接收人，第二列：郵件標題，第三列：正文，第四列：附件路徑注意：附件路徑中可以有中文，但是不能有空格這里你可以寫更多內(nèi)容，每一行作為一封郵件發(fā)出。注意：郵件正文是黑白文本內(nèi)容，不支持加粗、字體顏色等。（如果你需要支持彩色的郵件，后面將會給出解決辦法）2. 編寫宏發(fā)送郵件  a.) Alt + F11 打開宏編輯器，菜單中選：插入->模塊  b.) 將下面的代碼粘貼到模塊代碼

2、編輯器中：代碼list-1Public 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 nIDEvent As Long) As LongPrivate Declare

3、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)鍵之處，免安全提示自動發(fā)送郵件全靠它了 Application.SendKeys "%s"End F

4、unction' 發(fā)送單個郵件的子程序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

5、(olMailItem) With itmNewMail .subject = subject '主旨 .body = body '正文本文 .To = to_who '收件者 .Attachments.Add attachement '附件，如果你不需要發(fā)送附件，可以把這一句刪掉即可，Excel中的第四列留空，不能刪哦 .Display '啟動Outlook發(fā)送窗口 SetTimer 0, 0, 0, AddressOf WinProcA End With Set objOL = Nothing Set itmNewMail = NothingEnd

6、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) NextEnd Sub最終代碼編輯器中的效果如下圖： i為了正確執(zhí)行代碼，你還需要在菜單中選擇： 工具->引用 中的Micro

7、seft Outlook X.0 Object Library  勾選上 （X.0是版本號，不同機器可能不一樣）   c.) 粘貼好代碼、勾選上上面的東東后可以發(fā)送郵件了，點擊上圖A紅圈所示的綠色三角按鈕，會彈出下圖所示的對話框，點運行，就開始批量發(fā)送郵件了。   d.) 如果你想確認你的郵件是否都發(fā)出去了，可以去Outlook的“已發(fā)送郵件”文件夾中查看，是否有你希望發(fā)出的郵件，如果有，恭喜你，收工-下面講解1. 如何發(fā)送彩色的郵件2. 如何替換正文中的部分內(nèi)容，例如，每一封郵件中可能最開始的稱呼不同，給對方報出的數(shù)字不同等3. 如何發(fā)送多附

8、件-1. 如何發(fā)送彩色郵件發(fā)送彩色郵件需要兩步， 第一步：上面的代碼需要改一句（紅色加粗文本，body改成HTMLBody）：代碼list-2' 發(fā)送單個郵件的子程序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    '引用Micr

9、osoft Outlook 對象    Set objOL = CreateObject("Outlook.Application")    Set itmNewMail = objOL.CreateItem(olMailItem)    With itmNewMail        .subject = subject  '主旨 '        .HTMLbody = body   '正文

10、本文，僅僅這一行跟前面不同，其余都是一樣的哦        '        .To = to_who  '收件者        .Attachments.Add attachement '附件        .Display  '啟動Outlook發(fā)送窗口        SetTimer 0, 0, 0, AddressOf WinProcA&

11、#160;   End With    Set objOL = Nothing    Set itmNewMail = NothingEnd Sub第二步：修改excel第三列（C列）的內(nèi)容，這需要你懂一點點HTML語言 例如，希望在郵件中將“報稅單”三個字變紅，加粗，則將第三列的內(nèi)容修改為：您好，下面是這一周的<font color="red"><b>報稅單</b></font>，最終效果如圖：去發(fā)件箱里看看效果吧：注意：在Excel里面編輯正文，進行加粗、加顏色的操作不會生

12、效哦。必須用HTML自己來，sorry哦 不會HTML的朋友可以新浪微博follow我?guī)兔Γ貉芯繂TRaywill2. 如何替換正文部分內(nèi)容 分兩步：1. 換Excel內(nèi)容2. 換代碼1. 換Excel內(nèi)容：將變化的部分用=xxxx=這樣的形式替換掉。注意：中間沒有空格。例如上圖，數(shù)字=1=會被E列的內(nèi)容替換掉，=2=會被F列的內(nèi)容替換掉，依此類推，如果有更多，就添加更多列，=3=, =4=等等。2. 換代碼，將 "批量發(fā)送郵件"這一段程序完全替換成下面的代碼：'批量發(fā)送郵件Sub BatchSendMail() Dim rowCount, end

13、RowNo Dim newBody Dim replaceCount, maxReplaceCount Dim pattern endRowNo = Cells(1, 1).CurrentRegion.Rows.Count '逐行發(fā)送郵件 For rowCount = 1 To endRowNo ' 替換當前行模板內(nèi)容 maxReplaceCount = 2 ' 有幾處替換就寫幾，例子中有兩處，就寫2 newBody = Cells(rowCount, 3) For replaceCount = 1 To maxReplaceCount pattern = "

14、=" & CStr(replaceCount) & "=" newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount) Next ' 替換好了，發(fā)郵件咯！ SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4) NextEnd Sub注意：上面“maxReplaceCount = 2"這一行代碼，2需要改成你自己的

15、值，替換幾個地方就寫幾（新添加了幾個列就寫幾）上面添加了E、F兩列，就是2，如果你添加了3處替換（E、F、G列），就寫3. 不過，對于需要重復(fù)替換的內(nèi)容，不需要添加新列，例如，大話西游在郵件中出現(xiàn)了兩次，可以重復(fù)使用=2=來代表。3. 如何發(fā)送多附件在實際應(yīng)用場景中可能需要發(fā)送多封附件，其實很簡單，將SendMail子程序修改成下面的樣子即可：' 發(fā)送單個郵件的子程序Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As S

16、tring) 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 '收件者

17、.Display '啟動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 = NothingEnd Sub在Excel的附件列（第三列），多個附件用半角的分號分隔開（是”;"

18、;，不是”；“），例如： c:doc畢業(yè)證書附件.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 LongPublic Declare Function KillTimer Lib "user32" _ (ByVal hwnd

19、As Long, ByVal nIDEvent As Long) As LongPrivate 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)鍵之處，

20、免安全提示自動發(fā)送郵件全靠它了 Application.SendKeys "%s"End Function' 發(fā)送單個郵件的子程序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 =

21、 CreateObject("Outlook.Application") Set itmNewMail = objOL.CreateItem(olMailItem) With itmNewMail .subject = subject '主旨 .HTMLbody = body '正文本文 .To = to_who '收件者 .Display '啟動Outlook發(fā)送窗口 attaches = Split(attachement, "") For Each attach In attaches If (Len(attach)

22、 > 0) Then .Attachments.Add attach End If Next SetTimer 0, 0, 0, AddressOf WinProcA End With Set objOL = Nothing Set itmNewMail = NothingEnd Sub'批量發(fā)送郵件Sub BatchSendMail() Dim rowCount, endRowNo Dim newBody Dim replaceCount, maxReplaceCount Dim pattern endRowNo = Cells(1, 1).CurrentRegion.Rows

23、.Count '逐行發(fā)送郵件 For rowCount = 1 To endRowNo ' 替換當前行模板內(nèi)容 maxReplaceCount = 2 ' 有幾處替換就寫幾，例子中有兩處，就寫2 newBody = Cells(rowCount, 3) For replaceCount = 1 To maxReplaceCount pattern = "=" & CStr(replaceCount) & "=" newBody = WorksheetFunction.Substitute(newBody, patt

24、ern, Cells(rowCount, 4 + replaceCount) Next ' 替換好了，發(fā)郵件咯！ SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4) NextEnd Sub參考文獻： 本文發(fā)送郵件過程中不會彈出安全提示框，發(fā)件速度極快；)網(wǎng)友反饋：· 發(fā)件人：angel3814· 時間：2013-01-28 10:35:30您好，經(jīng)過測試，該方法對于大量發(fā)送郵件（大于100封。幾十封沒有問題。）有一些問題，因為程序必須在建立完成所有word發(fā)送窗口后，才會統(tǒng)一alt+S發(fā)送，很容易造成內(nèi)存不足，并且，最后的alt+S便不再執(zhí)行，在實際應(yīng)用中，我只能再寫一個按鈕，每次發(fā)送5封，發(fā)送完成計數(shù)+5，手工再點；想跟您請教，是否能有更好的改進方法？非常感謝angel3814提