如何使用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