【Excel VBA】- 使用CDO批量發送郵件（二）

前一期為大家介紹了如何使用VBA結合Outlook批量發送郵件，需要批量為不同的人發送不同的附件等，可以很方便的批量發送。但缺點是需要事先配置Outlook郵箱。那有沒有不需要配置Outlook即可批量發送郵件呢？答案是肯定的，那究竟什麼是CDO？如何使用CDO批量發送郵件呢？接下來就一一為大家揭曉。n

CDO（Collaboration Data Objects）：協作數據對象，從Exchange Server 2007和Outlook 2007開始，CDO 1.2.1作為不在產品安裝的一部分。CDO 1.2.1是通過基於COM的API提供對Outlook兼容對象的訪問的包。

既然知道了什麼是CDO，那究竟如何在Excel中使用CDO並批量發送郵件呢？

使用CDO必須提供一個郵箱服務，可以使用QQ或163等，下面介紹如何開通QQ的郵箱服務。

1 登錄QQ郵箱，進到主界面；

2 點擊上圖紅色框中的【設置】，進入郵箱設置界面；

3 點擊上圖紅色框中的【賬戶】，進入賬戶設置界面並找到【POP3/IMAP/SMTP...】等服務；

4 可以看到上圖中有個小的紅色框，我們需要開啟相應的服務，便於發送郵件，可以只開啟第一個POP3/SMTP服務。點擊開啟會彈出如下對話框，讓我升級為16位授權碼進行登錄，請見下圖：

5 點擊上圖中的立即升級，會讓我們用指定的手機號發送簡訊到1069070069，如下圖所示：

6 成功發送簡訊後，點擊上圖中的【我已發送】，會提示驗證成功，然後生成授權碼，如下圖所示：

PS：請不要隨意關閉和開啟以上的服務，因為每發送一條簡訊，運營商會收取0.1元，每開啟一項服務，就需要發送一條簡訊，所以安全是要付出代價的。

7 可以看到上圖下面的提示：可以擁有多個授權碼，所以無需記住該授權碼並且不要告訴他人。這裡我們需要記住該授權碼，因為需要在Excel中使用。成功開啟POP3/SMTP服務後，會發現狀態變為已開啟，如下圖所示：

通過上面幾個步驟的設置，準備工作就已經完成了，加下來就是批量發送郵件的核心代碼函數（請注意代碼中紅色字體）：

使用CDO發送郵件nPublic Function fSendEMailCDO(strTo As String, strSubject As String, strBody As String, Optional strAttachment As String = "", Optional strCC As String = "", Optional strBCC As String = "") As Objectn Dim CDOMail As Variantn Dim strUser, strPwd As Stringn On Error Resume Next 出錯後繼續執行n Application.DisplayAlerts = False 禁用系統提示nn strUser = "您的QQ號@qq.com" 請填寫您的郵箱地址n strPwd = "授權碼" 填寫我們上面申請開通的授權碼n If strTo = "" Then MsgBox "請輸入收件人地址~"n If strSubject = "" Then MsgBox "請輸入主題~"n If strBody = "" Then MsgBox "請輸入正文內容~"nn Set CDOMail = CreateObject("CDO.Message") 創建對象n CDOMail.From = strUser 設置發信人的郵箱nn CDOMail.To = strTo 設置收信人的郵箱n If ChkEmail(strCC) = 0 Thenn CDOMail.CC = strCC 設置抄送的郵箱n End Ifnn If ChkEmail(strBCC) = 0 Thenn CDOMail.BCC = strBCC 設置密送的郵箱n End Ifnn CDOMail.Subject = strSubject 設定郵件的主題nn If strBody Like "*html*" Thenn CDOMail.HTMLBody = strBody 使用Html格式發送郵件n Elsen CDOMail.TextBody = strBody 使用文本格式發送郵件n End Ifnn Dim strArrayn strArray = Split(strAttachment, "|")n For i = 0 To UBound(strArray)n CDOMail.AddAttachment ThisWorkbook.Path & "" & strArray(i) 如果有多個附件，分別添加n Nextnn SUTl = "http://schemas.microsoft.com/cdo/configuration/" 微軟伺服器網址nn With CDOMail.Configuration.Fieldsn .Item(SUTl & "smtpserver") = "smtp.qq.com" SMTP伺服器地址n .Item(SUTl & "smtpserverport") = 465 SMTP伺服器埠n .Item(SUTl & "sendusing") = 2 發送埠n .Item(SUTl & "smtpauthenticate") = 1 遠程伺服器需要驗證n .Item(SUTl & "smtpusessl") = 1 SSLn .Item(SUTl & "sendusername") = strUser 發送方郵箱名稱n .Item(SUTl & "sendpassword") = strPwd 發送方郵箱密碼n .Item(SUTl & "smtpconnectiontimeout") = 60 連接超時（秒）n .Updaten End Withn CDOMail.Send 執行發送n Set CDOMail = Nothing 發送成功後即時釋放對象nn Application.DisplayAlerts = True 恢復系統提示n Set fSendEMailCDO = Err 郵件發送情況nEnd Functionn

如上的代碼中都進行的詳細的注釋，也用到了前一期使用的檢查郵件是否合規的ChkEmail函數。需要發送的郵件信息如下圖所示：

為了能夠調用fSendEMailCDO函數，我寫了一個宏，用來循環調用該函數。宏代碼如下：

Sub 發送郵件()n Dim errMsg As Objectn Dim iCount As Integer, iTotal As Integernn Worksheets("Sheet1").Selectn Range("A2").Selectnn iCount = 0n iTotal = 0n Do While ActiveCell.Value <> ""n Set errMsg = fSendEMailCDO(ActiveCell.Value, ActiveCell.Offset(0, 1).Value, ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value, ActiveCell.Offset(0, 4).Value, ActiveCell.Offset(0, 5).Value)n If errMsg.Number = 0 Thenn iCount = iCount + 1n End Ifn iTotal = iTotal + 1n ActiveCell.Offset(1, 0).Selectn Loopnn MsgBox "共發送" & iTotal & "個，成功發送郵件" & iCount & "個！"nEnd Subn

把上面2個自定義函數（fSendEMailCDO和ChkEmail）和宏（發送郵件）放入同一個模塊中，然後在工作表中增加一個按鈕即可批量發送郵件了，請看如下演示：

今天的介紹就到此結束了，如果讓我來選，我首選使用CDO進行批量郵件發送，因為方便快捷，也不需要藉助於Outlook進行發送。而且發送郵箱的速度明顯要比Outlook要快捷。n

原創不易，每一個案例都是自己整理和自學而來。曾有多少次明明已經堅持不下去，想放棄了的時候，卻還是因為捨不得。希望各位看官多多轉發和點贊。給別人一點正能量的同時，也是給予自己正能量。Written by Steven in 20170425^_^

微信公眾號：SaveUTime

SUT學習交流群：615356012，入群審核人：Steven

關注公眾號，提高效率，節約您的時間！