使用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

參考文獻：

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

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

網友反饋：

• 發件人：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：http://www.blat.net/syntax/syntax.html

准備使用任何工具發送電子郵件信件。將其保存為文本文件，然后Blat發送到循環逐個。