excel - OlAppointment 对象的 HTMLBody 解决方法？

Question

我正在开发一个项目，该项目将 Outlook session 和约会从 Outlook 日历链接到格式化的 Excel 电子表格。我可以使用 VBA 毫无问题地提取 Outlook 约会/ session 。也就是说，当提取事件时，正文中的某些内容将不会导出到 Excel，特别是嵌入的 Excel 工作表对象。我的目标是将嵌入的 Excel 工作表链接到独立的 Excel 文件，该文件将用作仪表板。

到目前为止，我的代码能够提取 Outlook 邀请的发件人、约会日期和正文。问题是我似乎无法将嵌入的 Excel 工作表导出到 Excel。如果这是在电子邮件中，我知道我可以使用 .HTMLBody 属性并提取已标记为表格的数据。但是，由于我使用的是 olAppointmentItems 而不是 MailItems，所以我认为 HTMLBody 属性不是一个选项。

我希望有人能为我指明解决方法的方向，使我能够在 Outlook 中提取嵌入的工作表对象。我正在运行的代码的相关部分如下，我收到一条错误消息，指示 olAppointments 对象不支持 .HTMLBody 属性。公共(public)子中的调用中的变量是宏所在 Excel 工作表中的命名单元格。

如有任何建议，我们将不胜感激。谢谢!

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

我不知道这是否有很大帮助，但我遇到了无法将 Excel 文件(例如表格)中的范围插入到约会的问题。你是对的，如果这是一个电子邮件对象，就有可能使用 .HTMLBody 属性。

由于这是一个约会，因此您可以将之前选择的范围“复制并粘贴”到您的约会中。

这对我有用:

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

它是如何工作的？

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.

他是对的，我尝试使用 RTF 语法，这很糟糕。

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.

更多详情请参阅原始来源:Inserting a Range into an Outlook Appointment

希望对您有所帮助。