[英]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.