我的代码在默认日历中工作正常，但我无法让它在AllPublicFolder日历中进行预约。 我无法调用函数 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 FoldersAll Public FoldersBig Store A Calendar or
‘'Public FoldersAll Public FoldersBig 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
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 FoldersBig 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