Access to Outlook Public Folder

[SouthJoe]

I am able to use the following code to get my database to transfer
appointments to my own Outlook calendar, but how to I get the appointment to
go to a Public Folder that contains a calander?




Private Sub cmdAddAppt_Click()
On Error GoTo Add_Err
'Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
'Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment is already added to Microsoft Outlook"
Exit Sub
'Add a new appointment.
Else
Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern
Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
With objAppt
.Start = Me!ApptDate & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!Appt
If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNotes
If Not IsNull(Me!ApptLocation) Then .Location = Me!ApptLocation
If Me!ApptReminder Then
.ReminderMinutesBeforeStart = Me!ReminderMinutes
.ReminderSet = True
End If
Set objRecurPattern = .GetRecurrencePattern

With objRecurPattern
.RecurrenceType = olRecursWeekly
.Interval = 1
'Once per week
'You can hard-wire in these dates or get the
'information from text boxes, as used here.
'.PatternStartDate = #12/1/2003#
.PatternStartDate = Me!ApptStartDate
'.PatternEndDate = #12/30/2003#
.PatternEndDate = Me!ApptEndDate
End With
.Save
.Close (olSave)
End With
'Release the AppointmentItem object variable.
Set objAppt = Nothing
End If
'Release the object variables.
Set objOutlook = Nothing
.....Set objRecurPattern = Nothing
'Set the AddedToOutlook flag, save the record, display
'a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub

 

[Ralph]

You need to get the StoreID and EntryID (there is Help in Access for these
properties) for the folder. If the folder is in a sub folder on the public
drive it is a little more difficult but doable.

Sub oltest()
Dim ol As New Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFs As Outlook.Folders
Dim olMF As Outlook.MAPIFolder
Dim i As Integer
Set olNs = ol.GetNamespace("Mapi")

For i = 1 To olNs.Folders.Count
If olNs.Folders.Item(i).Name = "Public Folders" Then
Set olFs = olNs.Folders.Item(i).Folders
Set olMF = olFs.GetFirst

Do While Not olMF Is Nothing
If olMF.Name = "Customer Service" Then
Debug.Print olMF.EntryID
Debug.Print olMF.StoreID
Exit Do
End If
Set olMF = olFs.GetNext

Loop

End If

Next


End Sub