对于OlAppointment对象的HTMLBody解决方法？
我正在研究一个将Outlook会议和约会从Outlook日历链接到格式化的Excel电子表格的项目。 使用VBA，我可以毫无问题地展开预约/会议。 也就是说，当事件被拉出时，一些内容不会导出到Excel中，特别是embedded式的Excel工作表对象。 我的目标是将embedded式Excel工作表连接到独立的Excel文件，该文件将用作仪表板。
我到目前为止的代码能够拉取发件人，约会date和Outlook邀请的正文消息。 问题是，我似乎无法得到embedded的Excel工作表导出到Excel。 如果这是在电子邮件中，我知道我可以使用.HTMLBody属性，并将已标记为数据表的数据。 但是，因为我正在使用olAppointmentItems而不是MailItems，所以我认为HTMLBody属性不是一个选项。
我希望有人能指出我的方向，使我能够在Outlook中拉embedded式工作表对象。 我正在运行的代码的相关部分在下面，我收到一条错误消息，指出olAppointments对象不支持.HTMLBody属性。 公用Sub中调用的variables在macros所在的Excel Sheet中被命名为单元格。
任何build议将不胜感激。 谢谢！
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 我不知道这是否是一个很大的帮助，但我有问题不能够从我的Excel文件（例如表格）插入范围到约会。 你是对的，如果这是一个电子邮件对象，将有可能使用.HTMLBody属性。
由于这是一个约会，你有“复制和粘贴”你以前select的范围到你的约会。
这对我来说是有效的：
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正文中的格式化文本是RTF格式（RTF）。 我不知道有什么好的方法将范围转换为RTF。 当然，你可以学习所有的RTF代码，并build立string放入AppointmentItem的RTFBody属性。 然后，你可以去牙医没有novocaine根pipe。 我不确定哪一个会更有趣。
他是对的，我试图用可怕的RTF语法来工作。
更好的方法是以编程方式复制范围并将其粘贴到约会的正文中。 自Office 2007以来，几乎每个Outlook对象都允许您在Word中撰写。 这是我快速closures的一个选项，但它仍然在引擎盖下。 我们将利用这个优势。
有关更多详细信息，请参阅原始来源： 将范围插入到Outlook约会中
希望能以某种方式帮助你。