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

当我运行 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