OlAppointment 对象的 HTMLBody 解决方法? [英] HTMLBody Workaround For OlAppointment Object?

问题描述

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

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

我希望有人能指出一种解决方法的方向，使我能够在 Outlook 中提取嵌入的工作表对象.我正在运行的代码的相关部分如下所示，我收到一条错误消息，指出 olAppointments 对象不支持 .HTMLBody 属性.Public Sub 中 Call 中的变量是宏所在 Excel Sheet 中的命名单元格.

任何建议将不胜感激.谢谢！

Public Sub ExtractAppointments_ForPublic()带工作表(日历")调用 GetCalData(.Range("dtFrom").Value, .Range("dtTo").Value)结束于结束子Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)'来源:http://www.codeforexcelandoutlook.com/blog/2008/08/extract-calendar-data-from-outlook-into-excel/' -------------------------------------------------' 注释:' 如果 Outlook 未打开，它仍然可以工作，但速度要慢得多(约 8 秒 vs. 打开 Outlook 时为 2 秒).' 确保在运行代码之前引用 Outlook 对象库' 结束日期是可选的，如果您只想从一天中提取，请使用:Call GetCalData("7/14/2008")' -------------------------------------------------Dim olApp 作为对象Dim olNS 作为对象Dim objRecipient 作为对象Dim myCalItems 作为对象Dim ItemstoCheck As Object将 ThisAppt 调暗为对象Dim MyItem 作为对象Dim StringToCheck 作为字符串将 MyBook 调暗为 Excel.WorkbookDim rngStart As Excel.RangeDim strTable 作为字符串Dim strSharedMailboxName 作为字符串昏暗的我Dim NextRow As Long将 wsTarget 调暗为工作表设置 MyBook = Excel.ThisWorkbook'<-----------------------------------------------------------------'在此处设置工作表、表格和邮箱的名称！设置 wsTarget = MyBook.Worksheets("Calendar")strTable = "tblCalendar"strSharedMailboxName = wsTarget.Range("mailbox").Value'------------------------------------------------------------------>设置 rngStart = wsTarget.Range(strTable).Cells(1, 1)'清除以前的数据使用 wsTarget.Range(strTable)如果 .Rows.Count >1 然后 .Rows.Delete结束于' 如果没有指定结束日期，那么请求者只需要一天，所以设置 EndDate = StartDate' 这将让我们从多个日期返回应用程序，如果请求者确实设置了适当的结束日期如果 EndDate = "12:00:00 AM" 那么结束日期 = 开始日期万一如果结束日期<开始日期 然后MsgBox "这些日期似乎已切换，请检查它们并重试.", vbInformation转到退出程序万一如果结束日期 - 开始日期 >28 那么'询问请求者是否想要这么多信息If MsgBox("这可能需要一些时间.继续吗?", vbInformation + vbYesNo) = vbNo Then转到退出程序万一万一' 获取或创建 Outlook 对象并在继续之前确保它存在出错时继续下一步Set olApp = GetObject(, "Outlook.Application")如果 Err.Number <>0 那么Set olApp = CreateObject("Outlook.Application")万一出错时转到 0如果 olApp 什么都不是，那么MsgBox "无法启动 Outlook.", vbExclamation转到退出程序万一Set olNS = olApp.GetNamespace("MAPI")' 链接到共享日历设置 objRecipient = olNS.CreateRecipient(strSharedMailboxName)objRecipient.Resolve设置 myCalItems = olNS.GetSharedDefaultFolder(objRecipient, 9).Items '9=olFolderCalendar使用 myCalItems.Sort "[开始]", False.IncludeRecurrences = True结束于StringToCheck = "[开始] >= " &Chr(34) &开始日期和"12:00 AM" &Chr(34) &" AND [End] <= " &_Chr(34) &结束日期和晚上 11:59" &铬(34)设置 ItemstoCheck = myCalItems.Restrict(StringToCheck)如果 ItemstoCheck.Count >0 那么'我们找到了至少一个应用程序' 检查集合中是否真的有任何项目，否则退出如果 ItemstoCheck.Item(1) 什么都没有，那么 GoTo ExitProc对于 ItemstoCheck 中的每个 MyItemIf MyItem.Class = 26 Then ' 26=olAppointment.请参阅 https://msdn.microsoft.com/en-us/library/office/ff863329.aspx' MyItem 是我们想要的约会或会议项目，' 设置 obj 对它的引用设置 ThisAppt = MyItem' 有关文档，请参阅 https://msdn.microsoft.com/en-us/library/office/dn320241.aspx使用 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 作为我的想法.NextRow = wsTarget.Range(strTable).Rows.Count结束于万一下一个我的项目别的MsgBox "期间没有约会或会议" &_您指定的时间.现在退出."，vbCritical万一退出程序:设置 myCalItems = 无设置 ItemstoCheck = 无设置 olNS = 无设置 olApp = 无设置 rngStart = 无设置 ThisAppt = 无结束子函数 GetTableAsHTML(Meeting As Object, OutputLoc As Excel.Range)If Meeting.Class = 26 Then '#26 is defined as olAppointmentDim oHTML As MSHTML.HTMLDocument:设置 oHTML = New MSHTML.HTMLDocumentDim oElColl 作为 MSHTML.IHTMLElementCollection使用 oHTML出错时转到 0.Body = Meeting.HTMLBody出错时转到 0设置 oElColl = .getElementsByTagName("table")结束于昏暗 x 一样长，y 一样长对于 x = 0 到 oElColl(0).Rows.Length - 1对于 y = 0 到 oElColl(0).Rows(x).Cells.Length - 1Range(OutputLoc).Offset(x, y).Value = oElColl(0).Rows(x).Cells(y).innerText下一个下一个万一结束函数

解决方案

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

由于这是约会，因此您可以将之前选择的范围复制并粘贴"到约会中.

这对我有用:

Sub MakeApptWithRangeBody()Dim olApp 作为 Outlook.ApplicationDim olApt 作为 Outlook.AppointmentItemConst wdPASTERTF As Long = 1设置 olApp = Outlook.Application设置 olApt = olApp.CreateItem(olAppointmentItem)使用 olApt.开始 = 现在 + 1.End = 现在 + 1.2.Subject = "测试预约"Sheet1.ListObjects(1).Range.Copy.展示.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF结束于结束子

它是如何工作的?

<块引用>

与电子邮件不同，AppointmentItem 没有 HTMLBody 属性.如果是这样，那么我会将范围转换为 HTML 并使用它财产.AppointmentItem 正文中的格式化文本是丰富的文本格式 (RTF).我不知道有什么好的方法可以将范围转换为RTF.当然，您可以了解所有 RTF 代码并构建要放入 AppointmentItem 的 RTFBody 属性的字符串.然后你可以去看牙医进行非诺沃卡因根管治疗.我不是确定哪一个会更有趣.

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

<块引用>

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

更多详情请看原文:在 Outlook 约会中插入范围

希望能帮到你.

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

解决方案

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.

这篇关于OlAppointment 对象的 HTMLBody 解决方法?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！