发送带有附件和签名的Outlook电子邮件

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 = "[email protected]" 
    Email_Send_To = "[email protected]" 
    'Email_Cc = "[email protected]" 

    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") = "[email protected]" 
    .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 = "[email protected]" 

    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中&工作的Excel

在Outlook 2上测试010