它是如何工作的？

Question

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

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

我希望有人能指出我的解决方法，这将使我能够在Outlook中提取嵌入式工作表对象。我正在运行的代码的相关部分如下，我收到一条错误消息，指出olAppointments对象不支持.HTMLBody属性。 Public Sub中Call中的变量是宏所在的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属性。

由于这是一个约会，你有＆＃34; copy＆amp;粘贴＆＃34;您之前选择的预约范围。

这对我有用：

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

它是如何工作的？

与电子邮件不同，AppointmentItem没有HTMLBody属性。如果确实如此，那么我会将范围转换为HTML并使用它属性。 AppointmentItem正文中的格式化文本是Rich 文本格式（RTF）。我不知道将范围转换为的任何好方法 RTF。当然，您可以了解所有RTF代码是什么并构建要放入AppointmentItem的RTFBody属性的字符串。然后你可以去看牙医的无诺瓦卡因根管。我不是确定哪一个会更有趣。

他是对的，我尝试使用可怕的RTF语法。

更好的方法是以编程方式复制范围并将其粘贴到其中约会的身体。自Office 2007以来，几乎每一个Outlook 对象允许您在Word中撰写。这是我快速转向的选择关闭，但它仍然在引擎盖下。我们会用它来做我们的优点

有关详细信息，请参阅原始来源：Inserting a Range into an Outlook Appointment

希望以某种方式帮助你。

OlAppointment对象的HTMLBody解决方法？

1 个答案:

它是如何工作的？