[SOLVED] Adding Outlook Calendar item to a Public Folder from Access 2010

Adding Outlook Calendar item to a Public Folder from Access 2010

I am trying to add a calendar appointment from Access 2010 to an Outlook public calendar. I have found several ways to do this, but can't seem to get it to work with my code. One thing that may be the problem is that I don't understand what the code is doing when it's setting up the folder to save to. Here is my code that save to my Outlook calendar. How do I get it to save to a public Outlook calendar called janettest?

Private Sub Command60_Click()

     ' 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
         Dim dteTempEnd As Date
         Dim dteStartDate As Date
         Dim dteEndDate As Date

         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
                
        With olAppt
        
             If Nz(Me.AllDay_YesNo) = True Then
             
                 .Alldayevent = True

                 ' Get the Start and the End Dates
                 dteStartDate = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate)) ' Begining Date 
                 dteTempEnd = CDate(FormatDateTime(Me.txtEndDate, vbShortDate))      ' End Date   
                 ' Add one day to dteEndDate so Outlook will set the number of days correctly
                 dteEndDate = DateSerial(Year(dteTempEnd + 1), Month(dteTempEnd + 1), Day(dteTempEnd + 1))
  
                 .Start = dteStartDate
                 .End = dteEndDate
  
             Else
             
                 .Alldayevent = False
                 
                 If (Me.TxtBeginDate = Me.txtEndDate) Then
                 
                    ' Set the Start Property Value
                    .Start = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate) _
                        & " " & FormatDateTime(Me.txtStartTime, vbShortTime))
  
                    ' Set the End Property Value
                    .End = CDate(FormatDateTime(Me.txtEndDate, vbShortDate) _
                         & " " & FormatDateTime(Me.txtEndTime, vbShortTime))
                  
                 Else
                 
                    ' Get the Start and the End Dates
                    dteStartDate = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate))      
                    dteEndDate = CDate(FormatDateTime(Me.txtEndDate, vbShortDate))     
  
                    ' Add one day to dteEndDate so Outlook will set the number of days correctly
                    .Start = dteStartDate
                    .End = dteEndDate + 1
                 
                 End If
             End If
  
             If Len(Me.Employee & vbNullString) > 0 Then
                Dim vname, vname2, vdesc As String
                vname = DLookup("FirstName", "tblEmployees", "EmployeeID =  " & Me.Employee)
                vname2 = DLookup("LastName", "tblEmployees", "EmployeeID =  " & Me.Employee)
                vdesc = DLookup("Description", "tblCodesWork", "WorkCodeID  = " & Me.WorkCode)
                 .Subject = vname & " " & vname2 & " - " & vdesc

             End If

             ' Save the Appointment Item Properties
             .Save
             
         End With
  
         ' Set chkAddedToOutlook to checked
         Me.chkAddedToOutlook = True
  
         ' Inform the user
         MsgBox "New Outlook Appointment Has Been Added!", vbInformation
     End If
  
ExitHere:
     ' Release Memory
     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

Solution