如何使用CDO使用VBA發送郵件//郵件服務器是具有代理的Exchange

Question

這是我在VBA上的實際代碼...

Private Message As CDO.Message
Private Attachment, Expression, Matches, FilenameMatch, i

Sub enviar_mail()

    Set Message = New CDO.Message
    Message.Subject = "my subject here"
    Message.From = "jhony.donosso@road-track.com"
    Message.To = "jhony.donosso@road-track.com"
    Message.TextBody = "my text body here"

    Dim Configuration
    Set Configuration = CreateObject("CDO.Configuration")
    Configuration.Load -1 ' CDO Source Defaults
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "my_mail_server" 'A
    'Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 26
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "my_user"
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "my_pass"
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/urlproxyserver") = "my_url_proxy" 'B
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/urlproxyport") = "443" 'https
    Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/urlproxybypass") = "my_urlproxybypass" 'C

    Configuration.Fields.Update

    Set Message.Configuration = Configuration
    Message.Send
End Sub

當我運行該子程序時，收到以下消息：傳輸無法連接到服務器。

這是我的代理配置

Answer 1

您嘗試執行的操作不會起作用，因為您正在查看MAPI / HTTP代理設置，並嘗試通過SMTP發送消息（這是兩種不同的協議）。 因此，您需要為Exchange服務器使用實際的SMTP設置（例如，它應該是端口25或客戶端端口993），或者如果您知道EWS終結點（例如Office365），則可以考慮使用EWS

Sub SendMessage(Subject As String, Recipient As String, Body As String, User As String, Password As String)
   Dim sReq As String
   Dim xmlMethod As String
   Dim XMLreq As New MSXML2.XMLHTTP60
   Dim EWSEndPoint As String
   EWSEndPoint = "https://outlook.office365.com/EWS/Exchange.asmx"
   sReq = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
   sReq = sReq & "<soap:Envelope xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/"" xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & vbCrLf
   sReq = sReq & "<soap:Header>" & vbCrLf
   sReq = sReq & "<t:RequestServerVersion Version=""Exchange2010""/>" & vbCrLf
   sReq = sReq & "</soap:Header>" & vbCrLf
   sReq = sReq & "<soap:Body>" & vbCrLf
   sReq = sReq & "<CreateItem MessageDisposition=""SendAndSaveCopy"" xmlns=""http://schemas.microsoft.com/exchange/services/2006/messages"">" & vbCrLf
   sReq = sReq & "<SavedItemFolderId>" & vbCrLf
   sReq = sReq & "<t:DistinguishedFolderId Id=""sentitems"" />" & vbCrLf
   sReq = sReq & "</SavedItemFolderId>" & vbCrLf
   sReq = sReq & "<Items>" & vbCrLf
   sReq = sReq & "<t:Message>" & vbCrLf
   sReq = sReq & "<t:ItemClass>IPM.Note</t:ItemClass>" & vbCrLf
   sReq = sReq & "<t:Subject>" & Subject & "</t:Subject>" & vbCrLf
   sReq = sReq & "<t:Body BodyType=""Text"">" & Body & "</t:Body>" & vbCrLf
   sReq = sReq & "<t:ToRecipients>" & vbCrLf
   sReq = sReq & "  <t:Mailbox>" & vbCrLf
   sReq = sReq & "       <t:EmailAddress>" & Recipient & "</t:EmailAddress>" & vbCrLf
   sReq = sReq & "  </t:Mailbox>" & vbCrLf
   sReq = sReq & "</t:ToRecipients>" & vbCrLf
   sReq = sReq & "</t:Message>" & vbCrLf
   sReq = sReq & "</Items>" & vbCrLf
   sReq = sReq & "</CreateItem>" & vbCrLf
   sReq = sReq & "</soap:Body>" & vbCrLf
   sReq = sReq & "</soap:Envelope>" & vbCrLf
   xmlMethod = "POST"
   XMLreq.Open xmlMethod, EWSEndPoint, False, User, Password
   XMLreq.setRequestHeader "Content-Type", "text/xml; charset=""UTF-8"""
   XMLreq.setRequestHeader "Translate", "F"
   XMLreq.setRequestHeader "User-Agent", "Blah"
   XMLreq.send sReq
   If XMLreq.Status = 207 Then
   End If
End Sub