Question

我的代码在默认日历中工作正常，但无法在AllPublicFolders日历中进行约会。我无法调用函数GetPublicFolder，因为我是使用VBA的新手。任何帮助将不胜感激。

这是我的代码，其中“在所有公用文件夹中都存储有一个日历：

Option Explicit
Sub RegisterAppointmentList()

    ' adds a list of appointments to the Calendar in Outlook
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long

    On Error Resume Next
    'Worksheets("Schedule").Activate
    Worksheets("Appt").Activate

    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    'r = 6 ' first row with appointment data in the active worksheet
    r = 2 ' first row with appointment data in the active worksheet

    Dim mysub, myStart, myEnd
    While Len(Cells(r, 2).Text) <> 0
        mysub = Cells(r, 2) & ", " & Cells(r, 3)
        myStart = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
        myEnd = DateValue(Cells(r, 7).Value) + Cells(r, 8).Value
        'DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
            ' set default appointment values
            .Location = Cells(r, 2)
            .Body = Cells(r, 3).Value
            .ReminderSet = False
            .BusyStatus = olFree
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, 1)

            .Location = Cells(r, 2)
            .Body = Cells(r, 3).Value
            '.ReminderSet = True
            '.BusyStatus = olBusy
            .Categories = Cells(r, 4).Value
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
        End With
        r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olApp = Nothing

'   Print the Appt Sheet
    Sheets("Sheet1").PrintOut

    MsgBox "The Appt Sheet Printed and the Appt was entered in your default calendar on May 31st!"

End Sub
‘-------------------------I Need to get correct Public folder for the Exchange calendar -------------
‘I am using VBA for excel workbooks and need to create appointments in 2 public folder shared calendars
‘I need to get code like the code below to create appointments in the shared public calendar – ‘
‘I determine which calendar for the appointment using a workbook cell which is a list box of the 2 calendar names – 
‘ Big Store A Calendar or Big Store B Calendar
' GetFolder - Gets a Public folder based on a string path - e.g.
'If Folder name in English is
'Public Folders\All Public Folders\Big Store A Calendar   or 
‘'Public Folders\All Public Folders\Big Store B Calendar

Public Function GetPublicFolder(strFolderPath)
    Dim colFolders
    Dim objFolder
    Dim arrFolders
    Dim i
    On Error Resume Next
    strFolderPath = Replace(strFolderPath, "/", "\")
    arrFolders = Split(strFolderPath, "\")

    Set objFolder = Application.Session.GetDefaultFolder(18)      ‘This is the correct folder # for “All Public Folders”
    Set objFolder = objFolder.Folders.Item(arrFolders(0))
    If Not objFolder Is Nothing Then
        For i = 1 To UBound(arrFolders)
            Set colFolders = objFolder.Folders
            Set objFolder = Nothing
            Set objFolder = colFolders.Item(arrFolders(i))
            If objFolder Is Nothing Then
                Exit For
            End If
        Next
    End If
    Set GetPublicFolder = objFolder
    Set colFolders = Nothing
'     Set objApp = Nothing
    Set objFolder = Nothing
End Function

Answer 1

Set objFolder = Application.Session.GetDefaultFolder(18)中的应用程序是Excel。您要使用Outlook。

Sub DisplyOutlookPublicFolderFromExcel()

    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim pubCal As Folder

    Set olApp = CreateObject("Outlook.Application")
    Set pubCal = GetPublicFolder(olApp, "All Public Folders\Big Store A Calendar")

    pubCal.Display

    Set olAppItem = Nothing
    Set olApp = Nothing
    Set pubCal= Nothing

End Sub

Public Function GetPublicFolder(objApp, strFolderPath)

    Dim colFolders
    Dim objFolder
    Dim arrFolders
    Dim i
    On Error Resume Next
    strFolderPath = Replace(strFolderPath, "/", "\")
    arrFolders = Split(strFolderPath, "\")

    Set objFolder = objApp.Session.GetDefaultFolder(18)      'This is the correct folder # for “All Public Folders”
    Set objFolder = objFolder.Folders.Item(arrFolders(0))
    If Not objFolder Is Nothing Then
        For i = 1 To UBound(arrFolders)
            Set colFolders = objFolder.Folders
            Set objFolder = Nothing
            Set objFolder = colFolders.Item(arrFolders(i))
            If objFolder Is Nothing Then
                Exit For
            End If
        Next
    End If
    Set GetPublicFolder = objFolder
    Set colFolders = Nothing
    Set objApp = Nothing
    Set objFolder = Nothing
End Function

使用Excel在2013 MS Exchange中的所有公用文件夹日历中进行约会

1 个答案: