CDO.Message无法发送电子邮件

时间:2019-09-22 14:17:29

标签: vba cdo.message

CDO.MESSAGE不发送邮件。没有错误,但未收到Range("B2")中包含的电子邮件地址的邮件 我厌倦了尝试新方法。尝试了很多电子邮件ID,但没有成功。

Image attached for more clarity

Private Sub CommandButton1_Click()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "excel@vba.in.net"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.xyz.com"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Update
    End With

    strbody = "<H3>Topic Here:</H3>" & _
            "Body here<BR>"

    'Paste selected range for formatted text
    Dim cRange As Range
    Set cRange = Worksheets("Sheet1").Range("A8:T20").SpecialCells(xlCellTypeVisible)
    cRange.Select
    cRange.Copy
    cRange.PasteSpecial  '???
    'Application.ScreenUpdating = False

    With iMsg
        Set .Configuration = iConf
        .To = Sheets("sheet1").Range("c4")
        .CC = ""
        .BCC = ""
        .From = """VBA Macro"" <excel@vba.in.net>"
        .Subject = ThisWorkbook.Name
        .HTMLBody = strbody
'        .send

    End With
    MsgBox ("Email has been sent successfully.")
End Sub

0 个答案:

没有答案
相关问题