以VBA傳送郵件--CDO物件－YOUNG21975

CDO物件常用的屬性與方法

屬性或方法	作用說明
From	寄件者郵件地址（一般都必須有正確的網域名稱）
To	收件者郵件地址
Cc	副本收件者郵件地址
Bcc	密件副本收件者郵件地址
Subject	郵件主旨
TextBody	純文字內文
HTMLBody	HTML格式內文
ReplyTo	當收件者按下「回覆」信件時的收件者郵件地址
AddAttachment	加入附件
CreateMHTMLBody	傳送一個網頁
Send	傳送郵件

範例一（傳送一純文字郵件）

Sub sendmail()
Dim objEmail As Object
Set objEmail = CreateObject("CDO.Message") '建立 CDO 物件
objEmail.From = "abc@company.com" '寄件者（網域必須存在）
objEmail.To = "test@pchome.com" '收件者
objEmail.Subject = "CDO郵件測試" '郵件主旨
objEmail.TextBody = "郵件本文" '郵件內文
objEmail.Send
Set objEmail = Nothing
End Sub

範例二（傳送一HTML郵件經由遠端SMTP主機）

Sub sendmail()
Dim objEmail As Object
Const SMTPSERVER = "msa.hinet.net" '使用 msa.hinet.net 傳送郵件

Set objEmail = CreateObject("CDO.Message") '建立 CDO 物件
With objEmail.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPSERVER
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

objEmail.From = "abc@company.com" '寄件者（網域必須存在）
objEmail.To = "test@pchome.com" '收件者
objEmail.Subject = "CDO郵件測試" '郵件主旨
objEmail.HTMLBody = "郵件本文" 'HTML郵件內文
objEmail.Send
Set objEmail = Nothing
End Sub

範例三（將作用中的活頁簿當作附件傳給收件者，經由遠端SMTP主機）

Sub sendmail()
Dim fd As FileDialog
Dim objEmail As Object
Const SMTPSERVER = "msa.hinet.net" '使用 msa.hinet.net 傳送郵件

Set objEmail = CreateObject("CDO.Message") '建立 CDO 物件
With objEmail.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPSERVER
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

'檢查檔案是否已經存檔，存檔後才能當作附件傳送
If ActiveWorkbook.Path = "" Then
Set fd = Application.FileDialog(msoFileDialogSaveAs)
If Not fd.Show = -1 Then GoTo OUT
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fd.SelectedItems(1)
Application.DisplayAlerts = True
ElseIf Not ActiveWorkbook.Saved Then
If MsgBox("檔案需先儲存才能被傳送，要儲存檔案嗎？", vbYesNo) = vbNo Then GoTo OUT
ActiveWorkbook.Save
End If

Application.ScreenUpdating = False
'檔案被已可讀可寫的方式開啟時無法被加入附件
'所以需先變更檔案開啟屬性為唯讀才行
ActiveWorkbook.ChangeFileAccess xlReadOnly

With objEmail
.From = "abc@abc.com" '寄件者
.To = "test1@company.com" '收件者
.cc = "test2@company.com" '副本收件者
.Subject = "CDO郵件測試" '郵件主旨
.HTMLBody = "郵件本文『附加檔案』" 'HTML郵件內文
.AddAttachment ActiveWorkbook.FullName
.Send '傳送郵件
End With

Set objEmail = Nothing
'恢復檔案開啟屬性為可讀可寫
ActiveWorkbook.ChangeFileAccess xlReadWrite
Application.ScreenUpdating = True
Exit Sub
OUT:
MsgBox "檔案沒儲存，停止傳送"
Set objEmail = Nothing
End Sub