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

问题描述

我正在一个项目中，它将Outlook会议和约会从Outlook日历链接到格式化的Excel电子表格.我可以使用VBA顺利完成Outlook约会/会议.话虽这么说，当事件被拉出时，正文中的某些内容将不会导出到Excel，特别是嵌入式Excel工作表对象.我的目标是将嵌入式Excel工作表链接到一个独立的Excel文件，该文件将用作仪表板.

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.

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

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.

我希望有人可以指出一种解决方法，使我能够在Outlook中提取嵌入式工作表对象.我正在运行的代码的相关部分在下面，并且我收到一条错误消息，指示olAppointments对象不支持.HTMLBody属性.公用子菜单中的调用"中的变量在宏所在的Excel工作表中被命名为单元格.

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

推荐答案

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

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.

这对我有用:

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属性中的字符串.然后 您可以去牙医那儿找一个没有新烟碱的根管.我不是 确定其中哪一个会更有趣.

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语法.

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

更好的方法是以编程方式复制范围并将其粘贴到 任命的主体.自Office 2007起，几乎所有Outlook 对象允许您在Word中撰写.我很快就会选择 关闭，但仍在引擎盖下.我们将其用于我们的 优势.

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.

请参阅原始资源以获取更多详细信息:将范围插入Outlook约会

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

希望能以某种方式帮助您.

Hope that helps you somehow.

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