Question

我需要发送带有附件和签名的Outlook电子邮件。

以下是我的VBA代码。

我收到错误“Transport failedtoconnect server”。似乎我没有提供正确的SMTP服务器地址。

此外，我需要用公司徽标写签名。

Sub Outlook()

    Dim Mail_Object As Object
    Dim Config As Object
    Dim SMTP_Config As Variant
    Dim Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Body As      String
    Dim Current_date As Date


    Current_date = DateValue(Now)
    Email_Subject = "Daily Pending IMs Report (" & Current_date & ")"
    Email_Send_From = "report@xxxx.ae"
    Email_Send_To = "yyyyyy@gmail.com"
    'Email_Cc = "vvvvvv@telenor.com.pk"

    Email_Body = "Dear All," & vbCrLf & "" & vbCrLf & "Kindly find Daily Pending IMs Report in the attached files."

    Set Mail_Object = CreateObject("CDO.Message")

    On Error GoTo debugs
    Set Config = CreateObject("CDO.Configuration")
    Config.Load -1
    Set SMTP_Config = Config.Fields
    With SMTP_Config
     .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
     .Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
     .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "report@xxxx.ae"
     .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "nnnnnn"
     .Update
    End With

    With Mail_Object
        Set .Configuration = Config
    End With

    'enter code here
    Mail_Object.Subject = Email_Subject
    Mail_Object.From = Email_Send_From
    Mail_Object.To = Email_Send_To
    Mail_Object.TextBody = Email_Body
    Mail_Object.cc = Email_Cc
    'Mail_Object.AddAttachment "C:\Pending IMs\Pending IMs.pdf"


    Mail_Object.Send

debugs:
    If Err.Description <> "" Then MsgBox Err.Description

End Sub

Answer 1

如果您使用的是Outlook，那么您就不需要 CDO.Configuration

只需删除所有配置，

'// Code will work on Outlook & Excel 2010
Option Explicit
Sub Outlook()
    Dim olItem As Object ' Outlook MailItem
    Dim App As Object ' Outlook Application
    Dim Email_Subject, Email_To, Email_Cc, Email_Body As String
    Dim Current_date As Date

    Set App = CreateObject("Outlook.Application")
    Set olItem = App.CreateItem(olMailItem) ' olMailItem

'   // add signature
    With olItem
        .Display
    End With

    Current_date = DateValue(Now)
    Email_Subject = "Daily Pending IMs Report (" & Current_date & ")"
    Email_To = "yyyyyy@gmail.com"

    Email_Body = "Dear All," & vbCrLf & "" & vbCrLf & "See Report in the attached files."

    Set olItem.SendUsingAccount = App.Session.Accounts.Item(2)

    With olItem
        .Subject = Email_Subject
        .To = Email_To
        .HTMLBody = Email_Body & vbCrLf & vbCrLf & .HTMLBody
        .Attachments.Add ("C:\Temp\file001.pdf") ' update Attachment Path
       '.Send ' Send directly
        .Display ' Display it
    End With

'    // Clean up
    Set olItem = Nothing
End Sub

请记住，代码适用于Outlook＆amp; Excel中

在Outlook 2010上测试

发送包含附件和签名的Outlook电子邮件

1 个答案: