[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1005
  • Last Modified:

Assign appointments in Access to different Calendars in Outlook

I currently use the code below to book appointments from Access to Outlook. I would like to be able to book appointments to different calendars depending on one of the fields in the record.

This database is made to run off one computer, so all the Calendars are in the one Outlook. The calendars will be located within the default calendar folder.

The field I wish to determine which appointment goes where is "OrderTruck". It has 3 values, so I have 3 calendars I wish to use. "OrderTruck" is currently used to determine the category of the appointment.

I have found this code that may be of help, but with my extremely limited skills in VBA, I don't know how to adapt it.

The names of the calendars are:
1) Big
2) New
3) Mazda
Private Sub Command34_Click()
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Dim outNameSpace As Outlook.NameSpace
Dim outFolder As Outlook.Folder
Dim strMSG As String
Dim cnt As Long
 
    ' Save record first to be sure required fields are filled.
    If Me.Dirty Then Me.Dirty = False
     
    Set outobj = CreateObject("outlook.application")
     
    If IsNull(Me!GAID) Then
       Set outappt = outobj.CreateItem(olAppointmentItem)
       With outappt
            .Start = Me!OrderDate & " " & Me!OrderStartTime
               .End = Me!OrderDate & " " & Me!OrderEndTime
               .Subject = Me!OrderName
               .Categories = OrderTruck
               If Not IsNull(Me!OrderNotes) Then .Body = Me!OrderNotes
               If Not IsNull(Me!OrderPickUp) Then .Location = _
                  Me!OrderPickUp
            .Save
            Me!GAID = .GlobalAppointmentID
            Me!EID = .EntryID
       End With
    Else
        Set outNameSpace = outobj.GetNamespace("MAPI")
        Set outFolder = outNameSpace.GetDefaultFolder(olFolderCalendar)
 
' This is OK for EntryID but cant find the equivalant for GlobalAppointmentID
        Set outappt = outNameSpace.GetItemFromID(Me!EID, outFolder.StoreID)
        If outappt.GlobalAppointmentID <> Me!GAID Then
           MsgBox "The GlobalAppointmentID does not match"
        Else
           With outappt
               .Start = Me!OrderDate & " " & Me!OrderStartTime
               .End = Me!OrderDate & " " & Me!OrderEndTime
               .Subject = Me!OrderName
               .Categories = OrderTruck
               If Not IsNull(Me!OrderNotes) Then .Body = Me!OrderNotes
               If Not IsNull(Me!OrderPickUp) Then .Location = _
                  Me!OrderPickUp
            .Save
            Me.OrderHold = False
           End With
        End If
    End If
    
    ' Release the Outlook object variable.
    Set outobj = Nothing
     
    If Me.Dirty Then Me.Dirty = False
    MsgBox "Appointment Added / Updated"
    
AddAppt_Exit:
    Exit Sub
 
AddAppt_Err:
    Select Case Err
        Case Else
             strMSG = "An unexpected error has oocurred in AddAppt" & vbCrLf & vbCrLf & _
                      "Error " & vbTab & "Description" & vbCrLf & _
                      Err.Number & vbTab & Err.Description
             Select Case MsgBox(strMSG, vbCritical + vbAbortRetryIgnore, "Error in AddAppt")
                 Case vbAbort:  Resume AddAppt_Exit
                 Case vbIgnore: Resume Next
                 Case vbRetry:  Resume
             End Select
    End Select
End Sub

Open in new window

0
Greekiwi
Asked:
Greekiwi
  • 9
  • 9
1 Solution
 
TextReportCommented:
Rather than using the CreateItem of the Outlook Application you need to use the Folder. I have enhanced my routine that I provided in a previous question so it will handle folders undet the default calendar in Outlook 2007. The code does not create new folders and assumes you have already created the folders. If you do not specify the folder then the default calendar is used.

The changes I have made are
1. Added a new variable in the type called strFolder
2. Changed the code to use Add method of the Items collection of the Folders

Use the code as a replacement of the module you previously created then it will be much easier to handle changes as you will have a central piece of code that needs changing rather than having to make changes in multiple places.

Cheers, Andrew

Option Compare Database
Option Explicit
 
Public Type aiAppointment
    dtmStart As Date
    booAllDayEvent As Boolean
    lngDuration As Long
    dtmRecurrenceEnds As Date
    lngReminderMinutesBeforeStart As Long
    'dtmEnd As Date
    strSubject As String
    strCategories As String
    strBody As String
    strLocation As String
    strEntryID As String
    strGlobalAppointmentID As String
    booDelete As Boolean
    strFolder As String
End Type
 
Function OutlookAppointment(appt As aiAppointment)
On Error GoTo AddAppt_Err
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Dim outRecurrPatt As Outlook.RecurrencePattern
Dim outNameSpace As Outlook.NameSpace
Dim outFolder As Outlook.Folder
Dim strMSG As String
 
    Set outobj = CreateObject("outlook.application")
    Set outNameSpace = outobj.GetNamespace("MAPI")
    Set outFolder = outNameSpace.GetDefaultFolder(olFolderCalendar)
     
    If appt.strFolder <> "" Then
       Set outFolder = outFolder.Folders(appt.strFolder)
    End If
    
    If appt.strEntryID = "" Then
       Set outappt = outFolder.Items.Add
       
    Else
 
       ' This is OK for EntryID but cant find the equivalant for GlobalAppointmentID
       Set outappt = outNameSpace.GetItemFromID(appt.strEntryID, outFolder.StoreID)
       'If outappt.GlobalAppointmentID <> Me.txtGlobalAppointmentID Then
       '   MsgBox "The GlobalAppointmentID does not match"
       'Else
    End If
       
    With outappt
         If appt.booDelete Then
            .Delete
         Else
            If appt.dtmRecurrenceEnds = 0 Then
               .Start = appt.dtmStart
               If appt.booAllDayEvent Then
                  .AllDayEvent = True
               Else
                  .AllDayEvent = False
                  .Duration = appt.lngDuration
                  '.End = appt.dtmEnd
               End If
            Else
               Set outRecurrPatt = .GetRecurrencePattern
               With outRecurrPatt
                   .RecurrenceType = olRecursDaily
                   .PatternStartDate = DateSerial(Year(appt.dtmStart), Month(appt.dtmStart), Day(appt.dtmStart))
                   .PatternEndDate = DateSerial(Year(appt.dtmRecurrenceEnds), Month(appt.dtmRecurrenceEnds), Day(appt.dtmRecurrenceEnds))
                   .StartTime = TimeSerial(Hour(appt.dtmStart), Minute(appt.dtmStart), Second(appt.dtmStart))
                   If appt.booAllDayEvent Then
                      .Duration = 1440
                   Else
                      .Duration = appt.lngDuration
                   End If
                   
               End With
            
            
            End If
            
            .Subject = appt.strSubject
            .Categories = appt.strCategories
            .Body = appt.strBody
            .Location = appt.strLocation
         
            If appt.lngReminderMinutesBeforeStart <= 0 Then
               .ReminderSet = False
            Else
               .ReminderSet = True
               .ReminderMinutesBeforeStart = appt.lngReminderMinutesBeforeStart
               .ReminderOverrideDefault = True
               .ReminderPlaySound = True
               .ReminderSoundFile = SysCmd(acSysCmdAccessDir) & "Reminder.wav"
            End If
         
            .Save
            If Val(.OutlookVersion) >= 12 And appt.strGlobalAppointmentID = "" Then appt.strGlobalAppointmentID = .GlobalAppointmentID
            If appt.strEntryID = "" Then appt.strEntryID = .EntryID
         End If
    End With
    
    ' Release the Outlook object variable.
    Set outobj = Nothing
     
AddAppt_Exit:
    Exit Function
 
AddAppt_Err:
    Select Case Err
        Case Else
             strMSG = "An unexpected error has oocurred in AddAppt" & vbCrLf & vbCrLf & _
                      "Error " & vbTab & "Description" & vbCrLf & _
                      Err.Number & vbTab & Err.Description
             Select Case MsgBox(strMSG, vbCritical + vbAbortRetryIgnore, "Error in AddAppt")
                 Case vbAbort:  Resume AddAppt_Exit
                 Case vbIgnore: Resume Next
                 Case vbRetry:  Resume
             End Select
    End Select
 
End Function
 
Sub TestAppointment()
Dim appt As aiAppointment
 
'Create a new appointment
    With appt
        .dtmStart = Now() + 1
'        .dtmRecurrenceEnds = .dtmStart + 28
        .booAllDayEvent = False
        .lngDuration = 30
        .lngReminderMinutesBeforeStart = 10
        .strLocation = "Home"
        .strSubject = "Test Subject"
        .strFolder = "Big"
    End With
    OutlookAppointment appt
    MsgBox "Appointment Created"
    
' Update the appointment
    With appt
        .strBody = Format(Now(), "dd mmmm yyyy hh:nn") & " Test Data Update"
    End With
    OutlookAppointment appt
    MsgBox "Appointment Updated"
    
' delete the appointment
    With appt
        .booDelete = True
    End With
    OutlookAppointment appt
    MsgBox "Appointment Deleted"
 
End Sub

Open in new window

0
 
GreekiwiAuthor Commented:
Do I have to modify the module at all for my personal fields, or just the code that goes on the various buttons?
0
 
GreekiwiAuthor Commented:
I have used this code for my Add/ Update button:

Adding:
Seems to be fine except it doesn't seem to recognise the End Time of the appointment. I notice at the very start of your module there is no "dtmEnd As String" like there is for the start date.

Updating:
Same problem as above with regard to End date.
Of major concern though is that if I change the OrderTruck field, it will not move the appointment to the other calendar.
Private Sub Command34_Click()
Dim appt As aiAppointment
 
    With appt
        .dtmStart = Me!OrderDate & " " & Me!OrderStartTime
        .dtmEnd = Me!OrderDate & " " & Me!OrderEndTime
        .strSubject = Me!OrderName
        .strCategories = OrderTruck
        .strFolder = OrderTruck
        If Not IsNull(Me!OrderNotes) Then .strBody = Me!OrderNotes
        If Not IsNull(Me!OrderPickUp) Then .strLocation = Me!OrderPickUp
        If Not IsNull(Me!EID) Then .strEntryID = Me!EID
        If Not IsNull(Me!GAID) Then .strGlobalAppointmentID = Me!GAID
    End With
 
    OutlookAppointment appt
 
' This saves the ID's if they are not already set (New Appointments)
    If IsNull(Me!EID) Then Me!EID = appt.strEntryID
    If IsNull(Me!GAID) Then Me!GAID = appt.strGlobalAppointmentID
 
    MsgBox "Appointment Created / Updated"
 
End Sub

Open in new window

0
Microsoft Certification Exam 74-409

VeeamĀ® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 
TextReportCommented:
"Do I have to modify the module at all for my personal fields, or just the code that goes on the various buttons?" it should be just the code that goes on the various buttons that need amending.

I used to use End but I ended up commenting out line 10 of the code in http:#a23648247 as my code uses Duration rather than End and it also uses the booAllDayEvent option.

eg booAllDayEvent = True and Duration = 0
or booAllDayEvent = False and Duration = 30

You can modify your code to use Duration rather than end by changeing the line

.dtmEnd = Me!OrderDate & " " & Me!OrderEndTime
To
.Duration = DateDiff("n", .dtmStart, CDate(Me!OrderDate & " " & Me!OrderEndTime))

Cheers, Andrew
0
 
GreekiwiAuthor Commented:
Ah ok that fixed it.

I have some other questions:

1) If I update the OrderTruck field, can I make it so the appointment moves to the appropriate calendar? At the moment it changes the category, but not the calendar.

2) Where abouts in the Delete code so I add "Me!EID = Null"?
0
 
TextReportCommented:
1) I have the Move working initially but it is leading to an issue with not being able to find the appointment after it has been moved so any subsequent changes are not possible but I am working on this.

2) I would put it after the line

OutlookAppointment appt
Me!EID = Null
Me!GAID = Null

Cheers, Andrew

0
 
TextReportCommented:
I am now hitting a problem with the Entry_ID, when you MOVE the appointment the Entry_ID is updated. It may be necessary to ADD a new entry in the destination folder and DELETE the original entry.

Cheers, Andrew
0
 
GreekiwiAuthor Commented:
I really appreciate you working on this.
0
 
TextReportCommented:
Hi the code below should replace your main module, please take a backup of what you have (paste it into a word document or something)
The test will "move" the appointment by deleleting the original and then recreating it.

Cheers, Andrew
Option Compare Database
Option Explicit
 
Public Type aiAppointment
    dtmStart As Date
    booAllDayEvent As Boolean
    lngDuration As Long
    dtmRecurrenceEnds As Date
    lngReminderMinutesBeforeStart As Long
    'dtmEnd As Date
    strSubject As String
    strCategories As String
    strBody As String
    strLocation As String
    strEntryID As String
    strGlobalAppointmentID As String
    booDelete As Boolean
    strFolder As String
End Type
 
 
Function OutlookAppointment(appt As aiAppointment)
On Error GoTo AddAppt_Err
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Dim outRecurrPatt As Outlook.RecurrencePattern
Dim outNameSpace As Outlook.NameSpace
Dim outFolder As Outlook.Folder
Dim strMSG As String
 
    Set outobj = CreateObject("outlook.application")
    Set outNameSpace = outobj.GetNamespace("MAPI")
    Set outFolder = outNameSpace.GetDefaultFolder(olFolderCalendar)
     
    If appt.strFolder <> "" Then
       Set outFolder = outFolder.Folders(appt.strFolder)
    End If
    
    If appt.strEntryID = "" Then
       Set outappt = outFolder.Items.Add
       
    Else
 
       ' This is OK for EntryID but cant find the equivalant for GlobalAppointmentID
       Set outappt = outNameSpace.GetItemFromID(appt.strEntryID, outFolder.StoreID)
       'If outappt.GlobalAppointmentID <> Me.txtGlobalAppointmentID Then
       '   MsgBox "The GlobalAppointmentID does not match"
       'Else
    End If
       
    With outappt
         If appt.booDelete Then
            .Delete
            appt.strEntryID = ""
            appt.strGlobalAppointmentID = ""
         Else
            If appt.dtmRecurrenceEnds = 0 Then
               .Start = appt.dtmStart
               If appt.booAllDayEvent Then
                  .AllDayEvent = True
               Else
                  .AllDayEvent = False
                  .Duration = appt.lngDuration
                  '.End = appt.dtmEnd
               End If
            Else
               Set outRecurrPatt = .GetRecurrencePattern
               With outRecurrPatt
                   .RecurrenceType = olRecursDaily
                   .PatternStartDate = DateSerial(Year(appt.dtmStart), Month(appt.dtmStart), Day(appt.dtmStart))
                   .PatternEndDate = DateSerial(Year(appt.dtmRecurrenceEnds), Month(appt.dtmRecurrenceEnds), Day(appt.dtmRecurrenceEnds))
                   .StartTime = TimeSerial(Hour(appt.dtmStart), Minute(appt.dtmStart), Second(appt.dtmStart))
                   If appt.booAllDayEvent Then
                      .Duration = 1440
                   Else
                      .Duration = appt.lngDuration
                   End If
                   
               End With
            
            
            End If
            
            .Subject = appt.strSubject
            .Categories = appt.strCategories
            .Body = appt.strBody
            .Location = appt.strLocation
         
            If appt.lngReminderMinutesBeforeStart <= 0 Then
               .ReminderSet = False
            Else
               .ReminderSet = True
               .ReminderMinutesBeforeStart = appt.lngReminderMinutesBeforeStart
               .ReminderOverrideDefault = True
               .ReminderPlaySound = True
               .ReminderSoundFile = SysCmd(acSysCmdAccessDir) & "Reminder.wav"
            End If
         
'            If appt.strFolder <> "" Then
'               .Move outFolderSub
'            Else
               .Save
'            End If
            
            If Val(.OutlookVersion) >= 12 And appt.strGlobalAppointmentID = "" Then appt.strGlobalAppointmentID = .GlobalAppointmentID
            If appt.strEntryID <> .EntryID Then appt.strEntryID = .EntryID
         End If
    End With
    
    ' Release the Outlook object variable.
    Set outobj = Nothing
     
AddAppt_Exit:
    Exit Function
 
AddAppt_Err:
    Select Case Err
        Case Else
             strMSG = "An unexpected error has oocurred in AddAppt" & vbCrLf & vbCrLf & _
                      "Error " & vbTab & "Description" & vbCrLf & _
                      Err.Number & vbTab & Err.Description
             Select Case MsgBox(strMSG, vbCritical + vbAbortRetryIgnore, "Error in AddAppt")
                 Case vbAbort:  Resume AddAppt_Exit
                 Case vbIgnore: Resume Next
                 Case vbRetry:  Resume
             End Select
    End Select
 
End Function
 
Sub TestAppointment()
Dim appt As aiAppointment
 
'Create a new appointment
    With appt
        .dtmStart = Now() + 1
'        .dtmRecurrenceEnds = .dtmStart + 28
        .booAllDayEvent = False
        .lngDuration = 30
        .lngReminderMinutesBeforeStart = 10
        .strLocation = "Home"
        .strSubject = "Test Subject"
        .strFolder = "Truck1"
    End With
    OutlookAppointment appt
    MsgBox "Appointment Created"
    
' Update the appointment
    With appt
        .strBody = Format(Now(), "dd mmmm yyyy hh:nn") & " Test Data Update"
    End With
    OutlookAppointment appt
    MsgBox "Appointment Updated"
    
' Simulate a MOVE
    With appt
        .booDelete = True
    End With
    OutlookAppointment appt
    
    With appt
        .booDelete = False
        .strFolder = "Truck2"
'        .strBody = Format(Now(), "dd mmmm yyyy hh:nn") & " Test Data Update"
    End With
    OutlookAppointment appt
    MsgBox "Appointment Moved"
 
' delete the appointment
    With appt
        .booDelete = True
    End With
    OutlookAppointment appt
    MsgBox "Appointment Deleted"
 
End Sub

Open in new window

0
 
GreekiwiAuthor Commented:
Using this code (my Add/Update button) I still get the same result.


Private Sub Command34_Click()
Dim appt As aiAppointment
 
    With appt
        .dtmStart = Me!OrderDate & " " & Me!OrderStartTime
        .lngDuration = DateDiff("n", .dtmStart, CDate(Me!OrderDate & " " & Me!OrderEndTime))
        .strSubject = Me!OrderName
        .strCategories = OrderTruck
        .strFolder = OrderTruck
        If Not IsNull(Me!OrderNotes) Then .strBody = Me!OrderNotes
        If Not IsNull(Me!OrderPickUp) Then .strLocation = Me!OrderPickUp
        If Not IsNull(Me!EID) Then .strEntryID = Me!EID
        If Not IsNull(Me!GAID) Then .strGlobalAppointmentID = Me!GAID
    End With
 
    OutlookAppointment appt
 
' This saves the ID's if they are not already set (New Appointments)
    If IsNull(Me!EID) Then Me!EID = appt.strEntryID
    If IsNull(Me!GAID) Then Me!GAID = appt.strGlobalAppointmentID
    Me.OrderHold = False
    MsgBox "Appointment Created / Updated"
 
End Sub

Open in new window

0
 
TextReportCommented:
You need to take a look at the TestAppointment sub routine, this demonstrates how to delete and create the appointment.
Cheers, Andrew
0
 
GreekiwiAuthor Commented:
Is there anyway to have the code implemented into the Add/update button so as to remove the need for a "Move" button?
0
 
TextReportCommented:
Not sure at the moment as you need to detect if the Folder has changed.
0
 
GreekiwiAuthor Commented:
What about doing something with the "On Dirty" Event field of the OrderTruck field?
0
 
TextReportCommented:
It's possible and also the OldValue Property of the OrderTruck to see if it has changed. Cheers, Andrew
0
 
GreekiwiAuthor Commented:
Seeing as how the question has more or less been answered, and I am going for surgery tomorrow and will not have access to a computer for a couple of days, I will accept a solution.

However if you do find/ think of something that works I would be very happy to hear of it.
0
 
TextReportCommented:
Best of luck with the surgery and if I do find something I will let you know.
Cheers, Andrew
0
 
GreekiwiAuthor Commented:
Thanks, and thanks for the help with the question. Efficient and outstanding work as always.
0
 
jjafferrCommented:
Hi Andrew

Can you please look at a somehow a continuation to this post, by Greekiwi, here:
http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/Q_24377533.html

since you already worked the code, where in the other post
outappt.GlobalAppointmentID is required to be transfered from Outlook to Access.

thanks

jaffer
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 9
  • 9
Tackle projects and never again get stuck behind a technical roadblock.
Join Now