Hi Everyone,
I am very new to VBA. I found some code that will allow me to add an appointment to my personal calendar with using access VBA and it works great. It also allows me to add an appointment to another calendar created under "My Calendars" folder.
I wanted to know how to change the code in order to add the appointment to the SHARED calendar instead. Can you please change the code I post to show me how I would do this?
The main folder is called "Shared Calendars" which is at the same level as the default "My Calendars" folder. Under the "Shared Calendars" folder the calendar is called "Tester".
Thank you for your time.
Here is the code im using at the moment: I believe I have have to change the line of code that is in red but I don't know how. I am a noobie at VBA and Im learning as I go.
Private Sub cmdAddAppt_Click()
On Error GoTo cmdAddAppt_Err
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Dim olNS As Outlook.NameSpace
Dim olFolders As Outlook.MAPIFolder
Dim olSubCal As Outlook.MAPIFolder
' 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 already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Set outobj = CreateObject("outlook.application")
'set object Outlook NameSpace
Set olNS = outobj.GetNamespace("MAPI")
'get main calendar object
Set olFolders = olNS.GetDefaultFolder(olFolderCalendar)
'get sub calendar object
Set olSubCal = olFolders.Folders("Tester")
Set outappt = olSubCal.Items.Add
With outappt
.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
.Save
End With
End If
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
cmdAddAppt_Exit:
' Release the Outlook object variable.
Set outappt = Nothing
Set olSubCal = Nothing
Set olFolders = Nothing
Set olNS = Nothing
Set outobj = Nothing
Exit Sub
cmdAddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Resume cmdAddAppt_Exit
End Sub
I am very new to VBA. I found some code that will allow me to add an appointment to my personal calendar with using access VBA and it works great. It also allows me to add an appointment to another calendar created under "My Calendars" folder.
I wanted to know how to change the code in order to add the appointment to the SHARED calendar instead. Can you please change the code I post to show me how I would do this?
The main folder is called "Shared Calendars" which is at the same level as the default "My Calendars" folder. Under the "Shared Calendars" folder the calendar is called "Tester".
Thank you for your time.
Here is the code im using at the moment: I believe I have have to change the line of code that is in red but I don't know how. I am a noobie at VBA and Im learning as I go.
Private Sub cmdAddAppt_Click()
On Error GoTo cmdAddAppt_Err
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Dim olNS As Outlook.NameSpace
Dim olFolders As Outlook.MAPIFolder
Dim olSubCal As Outlook.MAPIFolder
' 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 already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Set outobj = CreateObject("outlook.application")
'set object Outlook NameSpace
Set olNS = outobj.GetNamespace("MAPI")
'get main calendar object
Set olFolders = olNS.GetDefaultFolder(olFolderCalendar)
'get sub calendar object
Set olSubCal = olFolders.Folders("Tester")
Set outappt = olSubCal.Items.Add
With outappt
.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
.Save
End With
End If
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
cmdAddAppt_Exit:
' Release the Outlook object variable.
Set outappt = Nothing
Set olSubCal = Nothing
Set olFolders = Nothing
Set olNS = Nothing
Set outobj = Nothing
Exit Sub
cmdAddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Resume cmdAddAppt_Exit
End Sub
