Hello, I hope I'm posting in the right place here.
I'm using the following code which I found on the internet to add Access appointments to my default Outlook calendar. It works great, but I would like appointments to be saved to a sub-calendar called printed instead. Is it possible, please? Many thanks. I'm using Office 365 ProPlus, Access 2002, Outlook 2002.
Code:
' You are welcome to use this code if you leave all authorship information intact
'---------------------------------------------------------------------------------------
' Procedure : btnAddApptToOutlook_Click
' DateTime : 7/09/2009
' Author : Patrick Wood
' Purpose : Add an Access Appointment Record to the Outlook Calendar
'---------------------------------------------------------------------------------------
'
Private Sub cmdSaveToOutlook_Click()
'On Error GoTo ErrHandle
Dim olNS As Object
Dim olApptFldr As Object
' Save the Current Record
If Me.Dirty Then Me.Dirty = False
' Exit the procedure if appointment has been added to Outlook.
If Me.chkAddedToOutlook = True Then
MsgBox "This appointment has already added to Microsoft Outlook.", vbCritical
Exit Sub
Else
' Use late binding to avoid the "Reference" issue
Dim olApp As Object 'Outlook.Application
Dim olAppt As Object 'olAppointmentItem
If isAppThere("Outlook.Application") = False Then
' Outlook is not open, create a new instance
Set olApp = CreateObject("Outlook.Application")
Else
' Outlook is already open--use this method
Set olApp = GetObject(, "Outlook.Application")
End If
Set olAppt = olApp.CreateItem(1) ' 1 = olAppointmentItem
' Add the Form data to the Appointment Properties
With olAppt
.Start = FormatDateTime(Me.txtNextDate, vbShortDate) _
& " " & FormatDateTime(Me.txtNextTime, vbShortTime)
.End = FormatDateTime(Me.txtNextDate, vbShortDate) _
& " " & FormatDateTime(Me.txtNextEndTime, vbShortTime)
If Len(Me.Duration & vbNullString) = 0 Then
Dim timStartTime As Date
Dim timEndTime As Date
' Format the Start Time and End Time
timStartTime = FormatDateTime(Me.txtNextDate, vbShortDate) _
& " " & FormatDateTime(Me.txtNextTime, vbShortTime)
timEndTime = FormatDateTime(Me.txtNextDate, vbShortDate) _
& " " & FormatDateTime(Me.txtNextEndTime, vbShortTime)
.Duration = Me.Duration
End If
.AllDayEvent = False
If Len(Me.StudentID & vbNullString) > 0 Then
.Subject = "lesson: " & Me.StudentID
End If
If Len(Me.Subject & vbNullString) > 0 Then
.Body = Me.Subject
End If
If Len(Me.AttendanceType & vbNullString) > 0 Then
.Location = Me.txtLocation
End If
.ReminderOverrideDefault = True
.ReminderMinutesBeforeStart = 5
.ReminderSet = True
.Categories = "2.John"
' Save the Appointment Item Properties
.Save
End With
' Set chkAddedToOutlook to checked
Me.chkAddedToOutlook = True
' Save the Current Record because we checked chkAddedToOutlook
If Me.Dirty Then Me.Dirty = False
' Inform the user
MsgBox "New Outlook Appointment Has Been Added!", vbInformation
End If
ExitHere:
' Release Memory
Set olApptFldr = Nothing
Set olNS = Nothing
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
ErrHandle:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description _
& vbCrLf & "In procedure btnAddApptToOutlook_Click in Module Module1"
Resume ExitHere
End Sub