excel 使用CDO寄送郵件－冠霖的部落格

CDO 是什麼東東？我不是這方面的專家，請大家造訪 [Collaboration Data Objects (CDO)] 慢慢爬一趟，就瞭解了。

說到使用電子郵件來寄送 WorkBook 或 WorkSheet，Ron de Bruin, Microsoft Excel MVP 是專家，大家造訪 [Working with Excel Workbooks and Worksheets in E-Mail] 就可以看到很多範例。關於在Excel中使用CDO寄送郵件，他也有專門網頁 [Sending mail from Excel with CDO] 解說並舉例。

最近看到有網友想讓excel自動發信：

1. 有30個工作表

2. email分別放在a2(有兩張工作表是總表沒email)

3. 執行巨集後可自動將個別工作表(以本文)寄出

4. 重點：寄出的工作表不以檔案方式寄送而是以本文方式寄出

因此，我就將我原本的內容依據這個要求改了一下。其中就引用到 Ron de Bruin 的 RangetoHTML 程序。

'Coded by crdotlin@2005.10.25
'Purpose: 使用CDO寄送郵件
'Advantage: 不必透過Outlook寄送
'Requisition: Microsoft CDO(the Collaboration Data Objects) for Windows 2000 Library

Option Explicit

'宣告模組變量及參數
Dim objCDO As CDO.Message
Public theRng As Range
Const myUserId = "yourID"       '請修改成你的帳號
Const myPassword = "yourPSW"    '請修改成你的帳號密碼
Const mySMTPServer = "smtp.gmail.com"  '請修改成你的寄送郵件伺服器
Const mySMTPport = 465      '須修改成你的送件伺服器使用的PORT, Gmail使用的是465

'流程控制
Sub Main()
    Application.StatusBar = "Sending..."        '狀態訊息顯示
    Set objCDO = New CDO.Message        '創建新的物件
    ServerSetting           '伺服器設置
    Set theRng = ActiveSheet.UsedRange      '取的作用工作表使用範圍
    fillNsend   '填充郵件各欄位資訊並寄送
    Set objCDO = Nothing        '釋放物件
    Application.StatusBar = False   '恢復狀態訊息
End Sub

'設置郵件伺服器參數
'這是我用Gmail測試成功的參數, 請參閱你的Email Server的設置說明取捨
Sub ServerSetting()
    With objCDO
        With .Configuration.Fields
            .Item(cdoSendUsingMethod) = cdoSendUsingPort
            .Item(cdoSendUserName) = myUserId
            .Item(cdoSendPassword) = myPassword
            .Item(cdoSMTPServer) = mySMTPServer
            .Item(cdoSMTPAuthenticate) = True
            .Item(cdoSMTPServerPort) = mySMTPport
            .Item(cdoSMTPUseSSL) = True
            .Update
        End With
    End With
End Sub

'填充欄位資訊後寄送
Sub fillNsend()
    With objCDO
        .From = """crdotlin""<" & myUserId & "@" & VBA.Mid(mySMTPServer, 6) & ">"
        .To = ActiveSheet.Range("a2").Text
        .Subject = "Test Test"
        .HTMLBody = RangetoHTML(theRng)
        .Send
    End With
End Sub

'測試
Sub TestSendSheet()
Dim Sht As Worksheet
'遍歷所有工作表
For Each Sht In ThisWorkbook.Worksheets
    Sht.Activate        '啟動為作用工作表
    '如果A2儲存格式郵件位址, 則將此工作表寄送到該信箱
    If ActiveSheet.Range("a2").Value Like "*@*" Then Main
Next
End Sub

我的作業環境：Vista, Office 2007

下載範例檔案

第二下載區
下載範例檔案