利用Excel批量高速寄送電子郵件

標籤：style   blog   http   color   使用   os   strong   io   

利用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 LongPublic Declare Function KillTimer Lib "user32" _        (ByVal hwnd 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發送郵件，這是本文的關鍵之處，免安全提示自己主動發送郵件全靠它了    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 = NothingEnd 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)    NextEnd Sub

終於代碼編輯器中的效果例如以：

i

為了正確運行代碼，你還須要在

菜單中選擇： 工具->引用 中的Microseft Outlook X.0 Object Library  勾選上 （X.0是版本，不同機器可能不一樣）

   c.) 粘貼好代碼、勾選上上面的東東後能夠發送郵件了，點擊A紅圈所看到的的綠色三角button，會彈出所看到的的對話方塊，點執行，就開始批量發送郵件了。

   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)            NextEnd Sub

注意：上面“maxReplaceCount = 2"這一行代碼，2須要改成你自己的值，替換幾個地方就寫幾（新加入了幾個列就寫幾）上面加入了E、F兩列，就是2，假設你加入了3處替換（E、F、G列），就寫3.

只是，對於須要反覆替換的內容，不須要加入新列，比如，《大話西遊》在郵件中出現了兩次，能夠反覆使用[==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 = NothingEnd 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 LongPublic Declare Function KillTimer Lib "user32" _        (ByVal hwnd 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發送郵件，這是本文的關鍵之處，免安全提示自己主動發送郵件全靠它了    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 = NothingEnd 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)            NextEnd Sub

參考文獻：

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

本文發送郵件過程中不會彈出安全提示框，發件速度極快；)

網友反饋：

• 寄件者：angel3814
• 時間：2013-01-28 10:35:30

您好，經過測試，該方法對於大量發送郵件（大於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 + 5End Sub

點一次，自己主動+5，再點

之所以用5，是測試發現，10以上，就有非常大幾率alt+S事件不生效（可能還是延遲問題？）

====

另外，對於希望批量發送郵件的同學，能夠不用把思維局限在Outlook上。假設你知道公司的郵件server的pop3地址，最好還是用命令列工具來實現郵件的批量自己主動發送。

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

先用隨意工具將一封封的郵件準備好，儲存為一個個文字檔，然後用Blat逐個迴圈發送就可以。