Copying the body of an email to the body of an appointment is converting the images to text

Question

I'm about to book a lot of appointments, so I made Outlook VBA code to pick out the info in the confirmation emails and make an appointment.

The problem is that instead of copying the email body with pictures, it is converting everything to text.

Public WithEvents olItems As Outlook.items

Public Sub Application_Startup()

    Dim olApp As Outlook.Application, olNS As Outlook.NameSpace

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olItems = olNS.GetDefaultFolder(olFolderInbox).items

    Debug.Print "Application_Startup triggered " & Now()

End Sub

Public Sub CreateAppointment()

    'Creates an appointment, inserts the open email as an attachment and as text, and sets appointment date and time.
    
    Dim eBody As Object, eName As Variant, eSched As Variant, eDate As Variant, eTime As Variant
    Dim MonthName As Variant, MonthNumber As Variant
    Dim SMBName As Variant, ApptDateTime As Variant
    Dim i As Variant, c As Variant
    Dim eMail As Object, eMail2 As Object
    Dim Appt As AppointmentItem, fldFolder As Folder, myItem As Object    
    Dim Ns As NameSpace
    
    Set eMail = GetCurrentItem()
    Set eBody = eMail
    
    eName = eMail.Body
    i = InStrRev(eName, "An appointment is coming up with ", -1) + 33
    c = InStrRev(eName, ", name", -1)
    SMBName = Mid(eName, i, c - i)
        
    i = InStrRev(eName, " on ", c + 100) + 4
    c = InStrRev(eName, Chr(40), -1) - 3
    eSched = Mid(eName, i, c - i)
    i = InStrRev(eSched, " at", -1) - 4
    c = Mid(eSched, i + 2, 2)
    MonthName = Mid(eSched, 1, i)
    eDate = DateValue(MonthName & " " & c & " " & Year(Date))
    i = InStrRev(eSched, Chr(58), -1) - 2
    eTime = Mid(eSched, i, 5) & ":00 " & Mid(eSched, i + 6, 2)
    eTime = TimeValue(eTime) + TimeSerial(2, 0, 0)
    ApptDateTime = eDate + eTime
    
    Set Ns = Application.GetNamespace("MAPI")
    Set fldFolder = Ns.GetDefaultFolder(olFolderCalendar)
    Set item = GetObject(, "Outlook.Application")
    Set Appt = Application.CreateItem(olAppointmentItem)
    With Appt
        .Body = eBody.Body
        .Attachments.Add eMail
        .Subject = SMBName
        .Categories = "Appointments"
        .Start = ApptDateTime
        .Duration = 45
    End With
    
    Appt.Move fldFolder
    
'    eMail2.Delete
    eMail.Close olDiscard
    
End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
           
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
       
    Set objApp = Nothing
End Function


'Private Sub olItems_ItemAdd(ByVal item As Object)

'Dim my_olMail As Outlook.MailItem

'If TypeName(item) = "MailItem" Then
'    If Subject(item) = "A Client Has Scheduled An Appointment" Then
'        'item.Open
'        Call CreateAppointment
'        'item.Close
        
'    Set my_olMail = item
'
'        Debug.Print my_olMail.Subject
'        Debug.Print my_olMail.SenderEmailAddress
'
'    Set my_olMail = Nothing
'End If

'End Sub

I'm still not getting the images out of the email body, but it is not translating those images anymore. Here is the version I'm going with.

Public WithEvents olItems As Outlook.items

Public Sub Application_Startup()

    Dim olApp As Outlook.Application, olNS As Outlook.NameSpace

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olItems = olNS.GetDefaultFolder(olFolderInbox).items

    'Debug.Print "Application_Startup triggered " & Now()

End Sub

Public Sub olItems_ItemAdd(ByVal item As Object)

    Dim my_olMail As Outlook.MailItem

    If TypeName(item) = "MailItem" Then
        If item.Subject = "A Client Has Scheduled An Appointment" Then
            Set my_olMail = item
            my_olMail.Display
            Call CreateAppointment
        End If

'        Debug.Print my_olMail.Subject
'        Debug.Print my_olMail.SenderEmailAddress

        Set my_olMail = Nothing
    End If

End Sub

Public Sub CreateAppointment()

    'Creates an appointment, inserts the open email as an attachment and as text, and sets appointment date and time.
    
    Dim eBody As Object, eName As Variant, eSched As Variant, eDate As Variant, eTime As Variant
    Dim MonthName As Variant, MonthNumber As Variant
    Dim SMBName As Variant, ApptDateTime As Variant
    Dim i As Variant, c As Variant
    Dim eMail As MailItem, eMail2 As Object
    Dim Appt As AppointmentItem, fldFolder As Folder, item As Object

    Dim Ns As NameSpace

    Set eMail = Application.ActiveInspector.CurrentItem
    Set eBody = eMail

    eName = eMail.Body
    i = InStrRev(eName, "An appointment is coming up with ", -1) + 33
    c = InStrRev(eName, ", name", -1)
    SMBName = Mid(eName, i, c - i)
    
    i = InStrRev(eName, " on ", c + 100) + 4
    c = InStrRev(eName, Chr(40), -1) - 3
    eSched = Mid(eName, i, c - i)
    i = InStrRev(eSched, " at", -1) - 4
    c = Mid(eSched, i + 2, 2)
    MonthName = Mid(eSched, 1, i)
    eDate = DateValue(MonthName & " " & c & " " & Year(Date))
    i = InStrRev(eSched, Chr(58), -1) - 2
    eTime = Mid(eSched, i, 5) & ":00 " & Mid(eSched, i + 6, 2)
    eTime = TimeValue(eTime) + TimeSerial(2, 0, 0)
    ApptDateTime = eDate + eTime
   
    Set Ns = Application.GetNamespace("MAPI")
    Set fldFolder = Ns.GetDefaultFolder(olFolderCalendar)
    Set item = GetObject(, "Outlook.Application")
    Set Appt = Application.CreateItem(olAppointmentItem)
    With Appt
        .Body = eBody.Body
        .Attachments.Add eMail
        .Subject = SMBName
        .Categories = "Appointments"
        .Start = ApptDateTime
        .Duration = 45
        .Display
        .Move fldFolder
    End With

    eMail.Close olDiscard

End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
           
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
       
    Set objApp = Nothing
End Function

Answer 1

The ApppointmentItem object does not expose the HTMLBody property. In the code you are dealing with the Body property which is a plain text string and can't contain any images:

With Appt
   .Body = eBody.Body

If you need to have any formatting you can set the RTFBody property instead. But even in case of RTF formatted text I think it is very inconvenient to deal with images. You can use the following workarounds:

You can use the Word object model for dealing with item bodies, so you can paste the HTML markup. See Chapter 17: Working with Item Bodies for more information.

For example, to add a picture to an item currently being displayed:

Application.ActiveInspector.WordEditor.Shapes.AddPicture

Recent Outlook versions (starting from 2016) allow to set a HTML markup as the message body by using a low-level property - PR_HTML (DASL name is http://schemas.microsoft.com/mapi/proptag/0x10130102). In that case you need to add the image as an attachment and set its PR_ATTACH_CONTENT_ID property using Attachment.PropertyAccessor.SetProperty to the cid used by the <img> tag in the HTML body markup.