2
Outlook予定表から予定されたExcelスプレッドシートへOutlook会議と予定をリンクするプロジェクトに取り組んでいます。私は、VBAを使用して問題なしにOutlookの予定や会議を引き出すことができます。つまり、イベントが取り出されると、本文からのコンテンツの一部がExcelに、特に埋め込まれたExcelワークシートオブジェクトにエクスポートされません。私の目標は、埋め込まれたExcelシートを、ダッシュボードとして機能するスタンドアロンのExcelファイルにリンクすることです。OlAppointmentオブジェクトのHTMLBody回避策？
私がこれまでに持っているコードは、Outlookの招待状の送信者、予定の日付、および本文を引き出すことができます。問題は、埋め込まれたExcelシートをExcelに書き出すことができないということです。これが電子メールの場合は、.HTMLBodyプロパティを使用して、タグとしてタグ付けされたデータをプルすることができます。しかし、私はolItemsではなくolAppointmentItemsで作業しているので、HTMLBodyプロパティはオプションではないと思います。
私は誰かが私に埋め込みワークシートオブジェクトを見通し内で引き出すことを可能にする回避策の方向を教えてくれることを願っています。私が実行しているコードの関連部分は以下の通りです。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