通过 64 位 Excel 引用共享日历

Question

我们创建了一个 VBA 脚本，通过单击 Excel 工作表中的按钮从 MS Outlook 中提取“共享日历”（已授予共享日历权限）。虽然代码在开发人员系统上运行良好，但它无法在其他系统上运行。它显示的错误是：

代码引用了 Outlook 16 库中的以下引用：

请提出代码不起作用的可能原因。我们认为原因之一可能是开发人员拥有 Office 365 的 32 位版本，而其他人拥有相同的 64 位版本。

附上代码供您参考：

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date
    Dim CalendarFolder As Outlook.Folder
    Dim myNameSPace As Outlook.Namespace
    Dim myRecipient As Outlook.Recipient
    Dim k, q As Long
    Dim abc(), fDate, tDate As String
    Dim i As Integer
    
    Sheets("Main").Select
    fDate = Range("B2").Value
    tDate = Range("C2").Value
    FromDate = CDate(fDate)
    ToDate = CDate(tDate)
    
    Sheets("Associates").Select
    k = Sheets("Associates").Range("A1048576").End(xlUp).Row
    k = k - 2
    ReDim abc(k)
    
    abc(0) = ""
    
    q = 0
    
    For i = 2 To k + 2
        abc(q) = Cells(i, 1).Value
        q = q + 1
    Next i
    
    Sheets("Main").Select
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set myNameSPace = Outlook.Application.GetNamespace("MAPI")
    
    'NextRow = 5
    
    'Starting multiple associates loop
    i = 0
    
    For i = 0 To k
    
    Set myRecipient = myNameSPace.CreateRecipient(abc(i))

    myRecipient.Resolve

    If myRecipient.Resolved Then
     Set CalendarFolder = myNameSPace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    End If
    
    q = Sheets("Main").Range("A1048576").End(xlUp).Row
    q = q + 1
    
    If q = 2 Then
     q = q + 3
    End If
    
    NextRow = q

    With Sheets("Main") 'Change the name of the sheet here
        .Range("A4:E4").Value = Array("Project", "Date", "Time spent", "Location", "User Email")
        For Each olApt In CalendarFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                .Cells(NextRow, "D").Value = olApt.Location
                .Cells(NextRow, "E").Value = abc(i)
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    Next i
    MsgBox ("Process Complete.")
    
End Sub

在这方面的任何帮助将不胜感激

Answer 1

我们解决了这个问题，只需要对这一行稍作改动： `

Set CalendarFolder = myNameSPace.GetSharedDefaultFolder(myRecipient, olFolderCalendar`)

我们所要做的就是在“olFolderCalendar”前面加上“outlook.olFolderCalendar”

Set CalendarFolder = myNameSPace.GetSharedDefaultFolder(myRecipient, outlook. olFolderCalendar)