excel - HTMLBody Workaround For OlAppointment Object?

Question

I am working on a project that links outlook meetings and appointments from an Outlook calendar to a formatted Excel spreadsheet. I am able to pull the outlook appointments/meetings without issue using VBA. That being said, when the events are pulled some of the content from the body will not export to Excel, specifically an embedded Excel worksheet object. My goal is to link the embedded Excel sheet to a stand-alone Excel file, which will serve as a dashboard.

The code I have thus far is able to pull the sender, appointment date, and the body message of the Outlook invite. The issue is that I cannot seem to get the embedded Excel sheet to export to Excel. If this were in an email, I know I could use the .HTMLBody property and pull the data that has been tagged as a table. However, since I'm working with olAppointmentItems and not MailItems, so I think the HTMLBody property isn't an option.

I am hoping someone can point me in the direction of a workaround that will enable me to pull the embedded worksheet object in outlook. The relevant parts of the code I'm running is below, and I receive an error message indicating that the olAppointments Object doesn’t support the .HTMLBody property. The variables in the Call in the Public Sub are named cells in the Excel Sheet the macro is in.

Any suggestions would be greatly appreciated. Thanks!

Public Sub ExtractAppointments_ForPublic()
With Worksheets("Calendar")
    Call GetCalData(.Range("dtFrom").Value, .Range("dtTo").Value)
End With
End Sub

Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)
'Source:  http://www.codeforexcelandoutlook.com/blog/2008/08/extract-calendar-data-from-outlook-into-excel/
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------

Dim olApp As Object
Dim olNS As Object
Dim objRecipient As Object
Dim myCalItems As Object
Dim ItemstoCheck As Object
Dim ThisAppt As Object
Dim MyItem As Object
Dim StringToCheck As String
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim strTable As String
Dim strSharedMailboxName As String
Dim i As Long
Dim NextRow As Long
Dim wsTarget As Worksheet

Set MyBook = Excel.ThisWorkbook

'<------------------------------------------------------------------
'Set names of worksheets, tables and mailboxes here!
Set wsTarget = MyBook.Worksheets("Calendar")
strTable = "tblCalendar"
strSharedMailboxName = wsTarget.Range("mailbox").Value
'------------------------------------------------------------------>

Set rngStart = wsTarget.Range(strTable).Cells(1, 1)

'Clear out previous data
With wsTarget.Range(strTable)
    If .Rows.Count > 1 Then .Rows.Delete
End With

' if no end date was specified, then the requestor only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates, if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
    EndDate = StartDate
End If

If EndDate < StartDate Then
    MsgBox "Those dates seem switched, please check them and try again.", vbInformation
    GoTo ExitProc
End If

If EndDate - StartDate > 28 Then
    ' ask if the requestor wants so much info
    If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
        GoTo ExitProc
    End If
End If

' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
    Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If olApp Is Nothing Then
    MsgBox "Cannot start Outlook.", vbExclamation
    GoTo ExitProc
End If

Set olNS = olApp.GetNamespace("MAPI")

' link to shared calendar
Set objRecipient = olNS.CreateRecipient(strSharedMailboxName)
objRecipient.Resolve
Set myCalItems = olNS.GetSharedDefaultFolder(objRecipient, 9).Items '9=olFolderCalendar

With myCalItems
    .Sort "[Start]", False
    .IncludeRecurrences = True
End With

StringToCheck = "[Start] >= " & Chr(34) & StartDate & " 12:00 AM" & Chr(34) & " AND [End] <= " & _
                Chr(34) & EndDate & " 11:59 PM" & Chr(34)

Set ItemstoCheck = myCalItems.Restrict(StringToCheck)

If ItemstoCheck.Count > 0 Then
    ' we found at least one appt
    ' check if there are actually any items in the collection, otherwise exit
    If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc

    For Each MyItem In ItemstoCheck
        If MyItem.Class = 26 Then ' 26=olAppointment. See https://msdn.microsoft.com/en-us/library/office/ff863329.aspx
            ' MyItem is the appointment or meeting item we want,
            ' set obj reference to it

            Set ThisAppt = MyItem

            ' see https://msdn.microsoft.com/en-us/library/office/dn320241.aspx for documentation

            With rngStart

                    .Offset(NextRow, 0).Value = ThisAppt.Subject
                    .Offset(NextRow, 1).Value = ThisAppt.Organizer
                    .Offset(NextRow, 2).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
                    .Offset(NextRow, 3).Value = ThisAppt.Body

                    'I need something here that will let me access the table in the 
                    'Outlook invite. See the Function I below as what I was thinking before I came across the issue above.                                             

                NextRow = wsTarget.Range(strTable).Rows.Count

            End With
        End If
    Next MyItem

Else
    MsgBox "There are no appointments or meetings during" & _
           "the time you specified. Exiting now.", vbCritical
End If

ExitProc:
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Sub

Function GetTableAsHTML(Meeting As Object, OutputLoc As Excel.Range)
    If Meeting.Class = 26 Then '#26 is defined as olAppointment
    Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
    Dim oElColl As MSHTML.IHTMLElementCollection
    With oHTML
        On Error GoTo 0
        .Body = Meeting.HTMLBody
        On Error GoTo 0
        Set oElColl = .getElementsByTagName("table")
    End With

    Dim x As Long, y As Long

    For x = 0 To oElColl(0).Rows.Length - 1
        For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
            Range(OutputLoc).Offset(x, y).Value = oElColl(0).Rows(x).Cells(y).innerText
        Next y
    Next x
End If


End Function

Answer 1

I don't know if this is much of a help but I had issues with not being able to insert a range from my Excel file (e.g. a table) to an Appointment. You are right, if this were an E-Mail object there would be the possibility to use the .HTMLBody property.

Since this is an appointment you have "copy & paste" your previously selected range into your appointment.

This is what worked for me:

Sub MakeApptWithRangeBody()

Dim olApp As Outlook.Application
Dim olApt As Outlook.AppointmentItem

Const wdPASTERTF As Long = 1

Set olApp = Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)

With olApt
    .Start = Now + 1
    .End = Now + 1.2
    .Subject = "Test Appointment"
    Sheet1.ListObjects(1).Range.Copy
    .Display
    .GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With

End Sub

How does it work?

Unlike email, the AppointmentItem does not have an HTMLBody property. If it did, then I would convert the range to HTML and use that property. Formatted text in the body of an AppointmentItem is Rich Text Format (RTF). I don’t know of any good ways to convert a range to RTF. Sure, you could learn what all the RTF codes are and build the string to put into the RTFBody property of the AppointmentItem. Then you could go to the dentist for a no-novocaine root canal. I’m not sure which of those would be more fun.

He is right, I tried to work with the RTF syntax which is horrible.

A better way is to programmatically copy the range and paste it into the body of the appointment. Since Office 2007, almost every Outlook object allows you to compose in Word. That’s an option I quickly turn off, but it’s still there under the hood. We’ll use that to our advantage.

Please see the original source for more details: Inserting a Range into an Outlook Appointment

Hope that helps you somehow.