[英]Extracting appointments from shared Outlook calendar to Excel
我正在嘗試使用 Excel 中的 VBA 宏將共享 Outlook 日歷中的約會提取到 Excel。 無論我嘗試將objOwner和olFolderCalendar定義為Object還是Outlook.Recipient / Outlook.Folder以在GetSharedDefaultFolder方法中使用,代碼都會失敗。
我收到運行時錯誤“13”:在以下行中鍵入不匹配錯誤:
Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
我做錯了什么?
Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim objOwner As Object
Dim olFolderCalendar As Object
Dim NextRow As Long
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set objOwner = olNS.CreateRecipient("test@test.com")
objOwner.Resolve
If objOwner.Resolved Then
MsgBox objOwner.Name
Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
Range("A1:D1").Value = Array("Subject", "Start", "End", "Location")
NextRow = 2
For Each olApt In olFolder.Items
Cells(NextRow, "A").Value = olApt.Subject
Cells(NextRow, "B").Value = olApt.Start
Cells(NextRow, "C").Value = olApt.End
Cells(NextRow, "D").Value = olApt.Location
NextRow = NextRow + 1
Next olApt
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Columns.AutoFit
End Sub
歡迎使用 StackOverflow!
您的問題的原因是為olFolderCalendar
使用了一個對象,但是在您嘗試執行的操作的上下文中,您需要 olFolderCalendar 的Enumeration
值,其值為9 。
我整理了代碼,並進行了一些優化以使此代碼更快,並添加了一個基本的錯誤處理程序。 偉大的第一篇文章:)
Option Explicit
Public Sub ListAppointments()
On Error GoTo ErrHand:
Application.ScreenUpdating = False
'This is an enumeration value in context of getDefaultSharedFolder
Const olFolderCalendar As Byte = 9
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object: Set olNS = olApp.GetNamespace("MAPI")
Dim olFolder As Object
Dim olApt As Object
Dim objOwner As Object: Set objOwner = olNS.CreateRecipient("emailAddressHERE")
Dim NextRow As Long
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
objOwner.Resolve
If objOwner.Resolved Then
Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
end if
ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")
'Ensure there at least 1 item to continue
If olFolder.Items.Count = 0 Then Exit Sub
'Create an array large enough to hold all records
Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olFolder.Items.Count - 1)
'Add the records to an array
'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
On Error Resume Next
For Each olApt In olFolder.Items
myArr(0, NextRow) = olApt.Subject
myArr(1, NextRow) = olApt.Start
myArr(2, NextRow) = olApt.End
myArr(3, NextRow) = olApt.Location
NextRow = NextRow + 1
Next
On Error GoTo 0
'Write all records to a worksheet from an array, this is much faster
ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)
'AutoFit
ws.Columns.AutoFit
cleanExit:
Application.ScreenUpdating = True
Exit Sub
ErrHand:
'Add error handler
Resume cleanExit
End Sub
這是@Ryan Wildry 為您編寫的帶有開始和結束日期輸入的代碼,以防您想將其導出到指定的時間段。 您需要添加以下幾行:
Dim FromDate As Date
Dim ToDate As Date
FromDate = InputBox("Enter the start date (format: yyyy/mm/dd)")
ToDate = InputBox("Enter the end date(format: yyyy/mm/dd)")
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
myArr(0, NextRow) = olApt.Subject
myArr(1, NextRow) = olApt.Start
myArr(2, NextRow) = olApt.End
myArr(3, NextRow) = olApt.Categories
NextRow = NextRow + 1
Else
End If
Next
On Error GoTo 0
你必須改變:
Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
有了這個:
Set olFolder = olNS.GetDefaultFolder(9)
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.