2006-11-02 01:46 以VBA傳送郵件--CDO物件
?VBA 好文轉寄 平均分數：0 顆星 投票人數：0 人
我要評分：
| 屬性或方法 | 作用說明 |
| 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 |
標籤 ： 