Results 1 to 6 of 6
  1. #1
    RasterImage is offline Advanced Beginner
    Windows 10 Access 2016
    Join Date
    Jun 2011
    Location
    UK
    Posts
    34

    Saving an appointment to non-default Outlook calendar.

    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

  2. #2
    Gicu's Avatar
    Gicu is offline VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jul 2015
    Location
    Kelowna, BC, Canada
    Posts
    4,101
    Have a look at this thread that shows how to use the sub-folder:
    https://www.access-programmers.co.uk...ss-vba.268162/

    Cheers,
    Vlad Cucinschi
    MS Access Developer
    http://forestbyte.com/

  3. #3
    RasterImage is offline Advanced Beginner
    Windows 10 Access 2016
    Join Date
    Jun 2011
    Location
    UK
    Posts
    34
    Thanks for the link, it looks like the right sort of area. But I've tried taking bits of code from that thread and putting it in my code, and I'm just getting errors.
    Similarly, I've tried replacing all my code with the code in the link, but I get 'unknown object errors'.
    Truth is, I don't really have a clue what I'm doing (sorry).
    Is it possible to get more specific guidance as to what exactly I need to change in my code to save to the Outlook calendar subfolder please? I'm afraid I don't really understand VBA at all and any help would be really gratefully appreciated.

  4. #4
    Gicu's Avatar
    Gicu is offline VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jul 2015
    Location
    Kelowna, BC, Canada
    Posts
    4,101
    Would you please try this and let me know:
    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
        Dim olItems as object 'vlad
     	
        ' 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 olNS = olApp.GetNamespace("MAPI")  'vlad
    	Set olItems = olNS.GetDefaultFolder(9).Folders("Printed").Items   'olFolderCalendar=9  'vlad
    
    
            'Set olAppt = olApp.CreateItem(1) ' 1 = olAppointmentItem   'vlad
     	Set olAppt = olItems.Add    'vlad
            ' 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
    Vlad Cucinschi
    MS Access Developer
    http://forestbyte.com/

  5. #5
    RasterImage is offline Advanced Beginner
    Windows 10 Office 365
    Join Date
    Jun 2011
    Location
    UK
    Posts
    34
    Wow that works perfectly, you make it look so easy! Thank you thank you thank you.

  6. #6
    Gicu's Avatar
    Gicu is offline VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jul 2015
    Location
    Kelowna, BC, Canada
    Posts
    4,101
    Glad to hear, you're very welcome!
    Cheers,
    Vlad

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Adding an appointment to Outlook shared calendar
    By simon123 in forum Programming
    Replies: 1
    Last Post: 08-03-2018, 11:14 AM
  2. Access - Outlook Appointment shared calendar
    By Guerra67 in forum Access
    Replies: 1
    Last Post: 09-21-2014, 07:26 PM
  3. Replies: 1
    Last Post: 05-31-2013, 02:04 AM
  4. Add appointment to public calendar
    By avarusbrightfyre in forum Import/Export Data
    Replies: 4
    Last Post: 02-19-2013, 11:00 AM
  5. Appointment Calendar Scheduling
    By IdleJack in forum Access
    Replies: 4
    Last Post: 08-18-2011, 07:29 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums