从共享的Outlook日历中提取约会到Excel [英] Extracting appointments from shared Outlook calendar to Excel
问题描述
我正在尝试使用Excel中的VBA宏将约会从共享的Outlook日历提取到Excel.无论我尝试将 objOwner 和 olFolderCalendar 定义为 Object 还是 Outlook.Recipient /,代码均失败在 GetSharedDefaultFolder 方法中使用的Outlook.Folder .
I am trying to extract appointments from a shared Outlook calendar to Excel using a VBA macro in Excel. The code fails whether I try to define objOwner and olFolderCalendar as either Object or Outlook.Recipient / Outlook.Folder for use in the GetSharedDefaultFolder method.
我得到运行时错误'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!
Welcome to StackOverflow!
问题的原因是将对象用于olFolderCalendar
,但是在尝试执行的操作中,您需要olFolderCalendar的Enumeration
值,其值为 9 .
The cause of your issue was using an object for olFolderCalendar
, however in context for what you are trying to do you want an Enumeration
value of olFolderCalendar which has a value of 9.
我整理了代码,并进行了一些优化以使此代码更快,并添加了基本的错误处理程序.很棒的第一篇文章:)
I've tidied up the code, and made a few optimization to make this code faster, and added a basic error handler. Great first post :)
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
这篇关于从共享的Outlook日历中提取约会到Excel的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!