Using Outlook 2016 VBA, Retain Attachment When Sending using SMTP/CDO

Question

I would like to avoid saving the attachment from the original Outlook message to a local drive and then reattach it to the SMTP message. The message body is recreated for the SMTP message, which works fine.

Sub ForwardEmail(myEmail As Outlook.MailItem) 'subroutine called from Outlook rule, when new incoming email message arrives
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0076001E"
Set objSMTPMail = CreateObject("CDO.Message") 'needed to send SMTP mail
Set objConf = CreateObject("CDO.Configuration") 'needed for SMTP configuration

Set objFlds = objConf.Fields 'used for SMTP configuration

'Set various parameters and properties of CDO object

objFlds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2     
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtpout.test.com" 'define SMTP server
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 'default port for email

objFlds.Update

objSMTPMail.Configuration = objConf

If myEmail.SenderEmailType = "EX" Then
  objSMTPMail.From = myEmail.Sender.GetExchangeUser.PrimarySmtpAddress
Else
  objSMTPMail.From = myEmail.SenderEmailAddress 'takes email address from   the original email and uses it in the new SMTP email
 objAttachments = myEmail.Attachments  ' I believe this is how to get the attachments

End If

objSMTPMail.Subject = myEmail.Subject 'use the subject from the original email message for the SMTP message
objSMTPMail.HTMLBody = myEmail.HTMLBody 'myEmail.HTMLBody is necessary to retain Electronic Inquiry Form formatting
objSMTPMail.To = "[email protected]"
objSMTPMail.AddAttachment objAttachments ' tried to add attachment
'send the SMTP message via the SMTP server
objSMTPMail.Send




'Set all objects to nothing after sending the email

Set objFlds = Nothing
Set objConf = Nothing
Set objSMTPMail = Nothing

End Sub

Answer 1

Here is my solution. It works for my situation.

Sub ForwardEmail(myEmail As Outlook.MailItem) 'subroutine called from Outlook rule, when new incoming email message arrives

On Error GoTo Resetvar
Set objSMTPMail = CreateObject("CDO.Message") 'needed to send SMTP mail
Set objConf = CreateObject("CDO.Configuration") 'needed for SMTP configuration

Set objFlds = objConf.Fields 'used for SMTP configuration

'Set various parameters and properties of CDO object

objFlds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'cdoSendUsingPort
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtpout.test.com" 'define SMTP server
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 'default port for email

objFlds.Update

objSMTPMail.Configuration = objConf

'EX value is an Exchange mailbox locally
If myEmail.SenderEmailType = "EX" Then
    objSMTPMail.From = myEmail.Sender.GetExchangeUser.PrimarySmtpAddress
Else
    objSMTPMail.From = myEmail.SenderEmailAddress 'takes email address from the original email and uses it in the new SMTP email
End If
Dim i As Integer
i = -1
Dim arrAtmt() As String
Dim FileName As String
For Each Atmt In myEmail.Attachments
    FileName = "C:\temp\" & myEmail.EntryID & "." & Atmt.FileName
    Atmt.SaveAsFile FileName
    i = i + 1
    ReDim Preserve arrAtmt(i)
    arrAtmt(i) = FileName
Next Atmt

    objSMTPMail.Subject = myEmail.Subject 'use the subject from the original email message for the SMTP message
    objSMTPMail.HTMLBody = myEmail.HTMLBody 'myEmail.HTMLBody is necessary to retain Electronic Inquiry Form formatting
    objSMTPMail.To = "[email protected]"

    If i > -1 Then
        For counter = 0 To i
            objSMTPMail.AddAttachment arrAtmt(counter)
        Next
    End If
    objSMTPMail.Send

Erase arrAtmt

Resetvar:

Set objFlds = Nothing
Set objConf = Nothing
Set objSMTPMail = Nothing

End Sub