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 = "nobody@test.com"
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

The following lines in the code are what I thought would work, but do not. objAttachments = myEmail.Attachments and then SMTPMail.AddAttachment objAttachments It only attaches an empty BIN file (file extension is BIN). — user9308240, Nov 21 '18 at 20:59
See [this answer](https://stackoverflow.com/questions/29232075/set-binary-base64-data-as-attachment-in-vb-script-cdo-message) (it's ASP, but should give the gist) for an idea of how to add an attachment that isn't from a file. Note that you'll need to find a Base64 encoder (or write one - it isn't hard). — Comintern, Nov 21 '18 at 21:02
@user9308240 I don't see `objAttachments` declared anywhere. If it should be an object reference, you might need to 1. `Dim` it as an object and 2. you might need to change `objAttachments = myEmail.Attachments` to `Set objAttachments = myEmail.Attachments`. To avoid these kinds of errors, putting `Option Explicit` at the top of the module/before your code can help. — chillin, Nov 21 '18 at 23:02
Thanks for the information. I will do some testing this evening and post an update by tomorrow morning. If it matters, the attachments could be anything such as a ODF, DOCX, JPEG, etc. I have worked with VBA very little and definitely not with Outlook , so it is new territory for me. — user9308240, Nov 26 '18 at 14:24
I found it easiest to save the file(s) locally and then reattach them to the SMTP message. — user9308240, Dec 02 '18 at 17:41

user9308240 · Answer 1 · 2018-12-02T18:27:02.927

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 = "mary@test.com"

    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

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

1 Answers1