- 帖子
- 582
- 主題
- 75
- 精華
- 0
- 積分
- 682
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office 2010
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-10-30
- 最後登錄
- 2026-4-13
|
用Excel整批寄電子郵件(Email)
Private Sub cmdSendMail_Click()
Dim objCdo As Object
'Dim objCdo As CDO.Message
strCfg = "http://schemas.microsoft.com/cdo/configuration/"
'Set objCdo = New CDO.Message
Set objCdo = CreateObject("CDO.Message")
i = 2
With objCdo
.From = Sheet1.Range("from")
.Fields("urn:schemas:mailheader:X-Priority") = 1 ' Priority = PriorityUrgent 高優先順序
.Configuration(strCfg & "sendusing") = 2 ' Sendusing = SendUsingPort
.Configuration(strCfg & "smtpserver") = Sheet1.Range("smtp") ' SMTP Server
.BodyPart.Charset = "utf-8" '使用編碼方式
End With
If Sheet1.Range("username") <> "" Then
' SMTP Server 如需登錄 , 則需設定 UserName / Password
objCdo.Configuration(strCfg & "sendusername") = Sheet1.Range("username")
objCdo.Configuration(strCfg & "sendpassword") = Sheet1.Range("password")
End If
objCdo.Configuration.Fields.Update ' 更新 (欄位) 組態
While Sheet2.Range("A" & i) <> ""
objCdo.To = Sheet2.Range("A" & i)
objCdo.CC = Sheet2.Range("B" & i)
objCdo.BCC = Sheet2.Range("c" & i)
objCdo.Subject = Sheet2.Range("d" & i)
If Sheet2.Range("A" & i) = "([email protected])" Then
MsgBox
Exit Sub
End If |
|
發表於 2012-11-9 22:58
| 
