Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Looping through Outlook Calendar Items in VBA (MS Access)

Posted on 2010-08-18
16
Medium Priority
?
1,966 Views
1 Endorsement
Last Modified: 2013-11-27
Our team uses a custom built task management software built in MS Access.  We also import appointments from Outlook into the database since there are a lot of meetings that need to be included in our time management reporting to Sr. Leadership of the team,

Up until now the code below has worked relatively well.  But, now it is suddenly not working for me and a few other people.  It is erroring out on the line "For Each itm in Itms" as a type mis-match error.  To make matters more interesting, it errors out the first time through and then will work the next time.  The third time it will fail.  The forth time it will work, etc.

We are running MS Access 2003 and MS Outlook 2003 (both with SP3) remoted into our team server that are running Windows Server 2008.

Public Sub GrabAppointments(dteStart As Date, dteEnd As Date)

Dim OUT As Outlook.Application
Dim itms As Outlook.Items
Dim itm As Outlook.AppointmentItem
Dim strLoggedIn As String
Dim ns As Outlook.NameSpace
Set OUT = New Outlook.Application
Set ns = Outlook.GetNameSpace("MAPI")
Dim rst As New ADODB.recordset
Dim rstTarget As New ADODB.recordset
Dim dteMax As Date  'stores latest event with Project assignment
Dim intCount As Long 'to count current appointments

strLoggedIn = LoggedIn()
If ns.CurrentUser = DLookup("OutlookUserName", "tblUsers", "User='" & strLoggedIn & "'") Then

    DoCmd.RunSQL "Delete * FROM tblTempAppointments;"
    rst.Open "Select * FROM tblTempAppointments", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Set itms = ns.GetDefaultFolder(olFolderCalendar).Items
        itms.IncludeRecurrences = True
        itms.Sort "[Start]"
    Set itms = itms.Restrict("[Start] >= '" & Format(dteStart, "mm/dd/yyyy") & "' AND [End] <='" & Format(dteEnd, "mm/dd/yyyy") & "'")
   
    '*** The Next Line is erroring out *******
   
    For Each itm In itms
        If itm.Sensitivity <> olPrivate Then
            rst.AddNew
                rst("RAT") = strLoggedIn
                rst("OutlookID") = itm.EntryID
                rst("StartDate") = Format(itm.Start, "mm/dd/yyyy")
                rst("EndDate") = IIf(itm.AlLDayEvent = True, Format(itm.End - 1, "mm/dd/yyyy"), Format(itm.End, "mm/dd/yyyy"))
                rst("StartTime") = Format(itm.Start, "h:m")
                rst("EndTime") = IIf(itm.AlLDayEvent = True, "11:59", Format(itm.End, "h:m"))
                rst("BusyStatus") = TranslateOlBusyStatus(itm.BusyStatus)
                Select Case itm.Sensitivity
                    Case olConfidential
                        rst("Subject") = "Confidential Appointment"
                        rst("Location") = ""
                    Case olNormal
                        rst("Subject") = itm.Subject
                        rst("Location") = itm.Location
                    Case olPersonal
                        rst("Subject") = "Personal Appointment"
                        rst("Location") = ""
                    Case olPrivate
                        rst("Subject") = "Private Appointment"
                        rst("Location") = ""
                End Select
                rst("AlLDayEvent") = itm.AlLDayEvent
            rst.Update
        End If
    Next
    Set rst = Nothing

********* Code that does that uses the new data to update the existing data via ADO recordsets ***********

Set OUT = Nothing
Set ns = Nothing
Set itms = Nothing
Set itm = Nothing
Set rst = Nothing

Any help would be greatly appreciated.

Thanks,

Amy Young



1
Comment
Question by:dond123
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 9
  • 6
16 Comments
 
LVL 6

Expert Comment

by:PhilAI
ID: 33467023
Dim itms As Outlook.Items

This variable is not restricted to Outlook.AppointmentItem objects so if you change the code as below you should see success for now.

It's not the ideal solution for you, but it should stop the error happening... I hope!

N.B. I have tagged the lines I've changed with a comment at the end like this ' *** NEW LINE ***
Public Sub GrabAppointments(dteStart As Date, dteEnd As Date)

Dim OUT As Outlook.Application
Dim itms As Outlook.Items
Dim citm As Object ' *** NEW LINE ***
Dim itm As Outlook.AppointmentItem
Dim strLoggedIn As String
Dim ns As Outlook.NameSpace
Set OUT = New Outlook.Application
Set ns = Outlook.GetNameSpace("MAPI")
Dim rst As New ADODB.recordset
Dim rstTarget As New ADODB.recordset
Dim dteMax As Date  'stores latest event with Project assignment
Dim intCount As Long 'to count current appointments

strLoggedIn = LoggedIn()
If ns.CurrentUser = DLookup("OutlookUserName", "tblUsers", "User='" & strLoggedIn & "'") Then

    DoCmd.RunSQL "Delete * FROM tblTempAppointments;"
    rst.Open "Select * FROM tblTempAppointments", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Set itms = ns.GetDefaultFolder(olFolderCalendar).Items
        itms.IncludeRecurrences = True
        itms.Sort "[Start]"
    Set itms = itms.Restrict("[Start] >= '" & Format(dteStart, "mm/dd/yyyy") & "' AND [End] <='" & Format(dteEnd, "mm/dd/yyyy") & "'")
    
    '*** The Next Line is erroring out *******
    
    For Each citm In itms ' *** AMENDED LINE ***
		If TypeOf citm Is Outlook.AppointmentItem Then ' *** NEW LINE ***
			Set itm = citm ' *** NEW LINE ***
			If itm.Sensitivity <> olPrivate Then
				rst.AddNew
					rst("RAT") = strLoggedIn
					rst("OutlookID") = itm.EntryID
					rst("StartDate") = Format(itm.Start, "mm/dd/yyyy")
					rst("EndDate") = IIf(itm.AlLDayEvent = True, Format(itm.End - 1, "mm/dd/yyyy"), Format(itm.End, "mm/dd/yyyy"))
					rst("StartTime") = Format(itm.Start, "h:m")
					rst("EndTime") = IIf(itm.AlLDayEvent = True, "11:59", Format(itm.End, "h:m"))
					rst("BusyStatus") = TranslateOlBusyStatus(itm.BusyStatus)
					Select Case itm.Sensitivity
						Case olConfidential
							rst("Subject") = "Confidential Appointment"
							rst("Location") = ""
						Case olNormal
							rst("Subject") = itm.Subject
							rst("Location") = itm.Location
						Case olPersonal
							rst("Subject") = "Personal Appointment"
							rst("Location") = ""
						Case olPrivate
							rst("Subject") = "Private Appointment"
							rst("Location") = ""
					End Select
					rst("AlLDayEvent") = itm.AlLDayEvent
				rst.Update
			End If
		End If ' *** NEW LINE ***
    Next
    Set rst = Nothing

********* Code that does that uses the new data to update the existing data via ADO recordsets ***********

Set OUT = Nothing
Set ns = Nothing
Set itms = Nothing
Set itm = Nothing
Set rst = Nothing

Open in new window

0
 

Author Comment

by:dond123
ID: 33467901
Thanks PhilAI.  I tried that.  None of the citm in itms are resolving as an Outlook.AppointmentItem, so nothing us updated.  

Any idea how I can figure out what item type the citm is?  I tried citm.type.  No luck.  

That does appear to be related to the problem since when I comment out lines 29 and 57 now, it gives me the same type mis-match error on line 30.
0
 
LVL 6

Expert Comment

by:PhilAI
ID: 33470237
Try using the function TypeName(citm) to find out the type.

Sorry it has taken me so long to reply - had to go out.
0
Fill in the form and get your FREE NFR key NOW!

Veeam® is happy to provide a FREE NFR server license to certified engineers, trainers, and bloggers.  It allows for the non‑production use of Veeam Agent for Microsoft Windows. This license is valid for five workstations and two servers.

 
LVL 2

Expert Comment

by:larkvale
ID: 33472558

To check if an item is an appointment item try one of these methods ....

1)    If oItem.Class = Outlook.OlObjectClass.olAppointment Then

       End If

Or

2)   If Item.MessageClass.ToString.ToLower  = "ipm.appointment"  Then

       End If

0
 

Author Comment

by:dond123
ID: 33474783
PhilAI's solution for finding out if the type of the citm in question.  

? TypeName(citm) returned "AppointmentItem"  so I modified line 29 in his first suggestion to read:
        If TypeName(citm) = "AppointmentItem" Then

That works . . . again, only the 1st, 3rd, 5th, etc. time through.  

Now it is giving me the type mis-match error on line 30 in the above code.

Here's what I know:
It is the first item in the list that is causing the issue on both my computer (and thus, my calendar) and another team member's computer (and thus, her calendar)
Yesterday, when the same issue was happening, the list of appointments would have started on the 8/15/2010.
Today, the list will start on the 8/16/2010.
The other team member and I do not share any appointments on the 8/16/2010 or 8/15/2010.
The same code works fine on my computer.  It does not work when I have remoted into our server and attempt to run the code, even though the calendar and versions are the same.
The same code works fine on another team member's computer, and fine when he logs into our server and runs the code.

I've tried working with Outlook Redemption to grab calendar information and have had no luck.  

Any ideas?

Thanks for all the help.
0
 
LVL 6

Accepted Solution

by:
PhilAI earned 500 total points
ID: 33475210
This is very unusal as I use this code to turn on an Out of Office for me automaitcally (don't try to understand all the code, the key here is I have used the same principle and it works like a dream for me :oS

Still trying to think what might be wrong...
''' <summary>
''' Find all the appointments where the current user will be out of the office.</summary>
Public Sub SetOutOfOffice()

Dim I As Integer
Dim dtNextUKBankHoliday As Date
Dim dtNextWorkingDay As Date
Dim dtOutOfOfficeEnd As Date
Dim dtOutOfOfficeStart As Date
Dim nsCurrent As Outlook.NameSpace
Dim fdrCalendar As Outlook.Folder
Dim itmFiltered As Outlook.Items
Dim sItemFilter As String
Dim objCurrentItem As Object
Dim apiCurrent As Outlook.AppointmentItem
Dim sOutOfOfficeMessage As String
Dim sNextOutOfOfficeMessage As String
Dim vWorkingDays() As Variant

On Error GoTo ERR_HANDLER
Dim dtToday As Date
dtToday = Date
'dtToday = CDate("31 Mar 2010 08:30") 'CDate("30 Dec 2009 11:45")

If Not IsOutOfOffice Then
    ' Get the next working day from today.
    dtNextWorkingDay = NextWorkingDay(dtToday)
    ' Get the next UK bank holiday from today.
    dtNextUKBankHoliday = NextUKBankHoliday(dtToday)

    Set nsCurrent = Application.GetNamespace("MAPI")
    Set fdrCalendar = nsCurrent.GetDefaultFolder(olFolderCalendar)

    ' Filter the appointments to improve performance.
    sItemFilter = cItemFilter
    sItemFilter = Replace(sItemFilter, cItemFieldStart, Format(DateAdd("s", -86399, dtNextWorkingDay), "d mmm yyyy"))
    sItemFilter = Replace(sItemFilter, cItemFieldEnd, Format(dtNextWorkingDay + cAppointmentSearchPeriod, "d mmm yyyy"))
    Set itmFiltered = fdrCalendar.Items.Restrict(sItemFilter)

    ' Sort the appointments by Start date in ascending order.
    Call itmFiltered.Sort("[Start]", False)

    For Each objCurrentItem In itmFiltered
        If TypeOf objCurrentItem Is Outlook.AppointmentItem Then
            Set apiCurrent = objCurrentItem
            With apiCurrent
                If zIsAppointmentWithinWorkingHours(dtToday, .Start, .End, dtOutOfOfficeEnd, sNextOutOfOfficeMessage, vWorkingDays) Then
                    If dtOutOfOfficeStart = 0 Then
                        dtOutOfOfficeStart = zNextDayOff(.Start, dtNextUKBankHoliday)
                    End If
                    dtOutOfOfficeEnd = zLastDayOff(dtOutOfOfficeStart, dtNextWorkingDay, dtNextUKBankHoliday, .Start, .End)
                    sOutOfOfficeMessage = zCreateOutOfOfficeMessage(dtOutOfOfficeStart, dtOutOfOfficeEnd)
                ElseIf Len(sOutOfOfficeMessage) = 0 _
                 And Len(sNextOutOfOfficeMessage) = 0 _
                 And InterceptWorkingWeek(.Start, .End, vWorkingDays) Then
                    If dtOutOfOfficeStart = 0 Then
                        dtOutOfOfficeStart = zNextDayOff(.Start, dtNextUKBankHoliday)
                    End If
                    dtOutOfOfficeEnd = zLastDayOff(dtOutOfOfficeStart, dtNextWorkingDay, dtNextUKBankHoliday, .Start, .End)
                    sNextOutOfOfficeMessage = zCreateOutOfOfficeMessage(dtOutOfOfficeStart, dtOutOfOfficeEnd)
                ElseIf dtOutOfOfficeStart > 0 Then
                    Dim dtNextWorkingDayAfterEnd As Date
                    dtNextWorkingDayAfterEnd = NextWorkingDay(dtOutOfOfficeEnd - 1)
                    
                    If dtNextWorkingDayAfterEnd >= .Start And dtNextWorkingDayAfterEnd <= .End Then
                        dtOutOfOfficeEnd = .End
                        If Len(sOutOfOfficeMessage) > 0 Then
                            sOutOfOfficeMessage = zCreateOutOfOfficeMessage(dtOutOfOfficeStart, dtOutOfOfficeEnd)
                        Else
                            sNextOutOfOfficeMessage = zCreateOutOfOfficeMessage(dtOutOfOfficeStart, dtOutOfOfficeEnd)
                        End If
                    Else
                        Exit For
                    End If
                End If
            End With
        End If
    Next objCurrentItem

    If Len(sOutOfOfficeMessage) > 0 Then
        Debug.Print sOutOfOfficeMessage
    ElseIf Len(sNextOutOfOfficeMessage) = 0 Then
        Dim dtEndOfUKBankHoliday As Date
        dtEndOfUKBankHoliday = zLastDayOff(dtNextUKBankHoliday, dtNextWorkingDay, dtNextUKBankHoliday, 0, 0)
        sNextOutOfOfficeMessage = _
         zCreateOutOfOfficeMessage(dtNextUKBankHoliday, _
                                   dtEndOfUKBankHoliday, _
                                   NextWorkingDay(DateAdd("s", -1, dtNextUKBankHoliday)))
    End If
    If Len(sNextOutOfOfficeMessage) > 0 Then
        Debug.Print sNextOutOfOfficeMessage
    End If

    If Len(sOutOfOfficeMessage) > 0 Then
        ' Turn on "Out of Office".
        OutOfOfficeMessage = sOutOfOfficeMessage
        IsOutOfOffice = True
        Call TurnOffOutOfOffice
    Else
        ' Ensure "Out of Office" is off.
        IsOutOfOffice = False
        OutOfOfficeMessage = sNextOutOfOfficeMessage
    End If
End If

PROCEDURE_EXIT:
Set apiCurrent = Nothing
Set objCurrentItem = Nothing
Set itmFiltered = Nothing
Set fdrCalendar = Nothing
Set nsCurrent = Nothing

Exit Sub

ERR_HANDLER:
If Not Err = 0 Then
    Debug.Print "Error #" & Err.Number & ": " & Err.Description
    Stop
End If

Resume PROCEDURE_EXIT

End Sub

Open in new window

0
 

Author Comment

by:dond123
ID: 33484718
The one difference it seems between your code and my code is that I include recurring events.

  itms.IncludeRecurrences = True

Thanks again for all the help!
0
 
LVL 6

Expert Comment

by:PhilAI
ID: 33485031
I noticed that. And tested it with recurrences also. Even created a recurrence that got picked up. And it still works!?
0
 
LVL 6

Expert Comment

by:PhilAI
ID: 33485035
In fact, I have now left my code to pick up recurrences because I thought it would be a good idea - thanks!
0
 
LVL 6

Expert Comment

by:PhilAI
ID: 33485049
Sorry to bombard you with copmments, but I wonder whether the data is corrupt? Have you tired stepping through the code in Debug mode and checking the object using the Immediate window?
0
 

Author Comment

by:dond123
ID: 33485882
Yep.  I step through code.  It breaks on the first interation through the code at that line.   And the plot thickens.  

In an attempt to get past the type mis-match error, I change my itm variable to a variant.  And success!  I got past the type mis-match error.

The code breaks again on this line:  rst("OutlookID") = itm.EntryID
It returns Run-time error 287 (Application-defined or object-defined error).

Using the immediate window, I can successfully print to the debug window:
itm.start
itm.subject
itm.end
itm.busystatus
etc.

The one item I can't seem to capture is itm.entryID.  

I use that field later on to determine if the new data should replace existing data in the database.  

Any ideas?

Thanks!



0
 
LVL 6

Expert Comment

by:PhilAI
ID: 33485915
0
 
LVL 6

Expert Comment

by:PhilAI
ID: 33485973
Sorry, forgot to say why. It seems the EntryID property has changed slightly - not sure how this affects you but it certainly could be the reason. Do you know if the error occurs on a recurrence appointment? Perhaps this is a versioning problem? Do you have different version of Outlook?
0
 

Author Comment

by:dond123
ID: 33487882
Thanks for the tip.  Did see that comment about the MAPI entryID.  We are not running MS Office 2007 on the server, so that shouldn't be the issue.

I verified the version of Outlook across the different workstations and the serers.  Same Version.  Same Service Pack.

And here's the really fun part.  There is no longer any issue.  I've modified the code as you suggestion PhilAI, but that's only on my development version of the database.  The original user that had the problem also reports that the problem is resolved and she is running the old code.  

Sigh.  At least it is fixed for the moment.  I'll let you know if it comes back up on Monday.

Thanks for the help!
0
 
LVL 6

Expert Comment

by:PhilAI
ID: 33488301
Very strange, but it could be down to the appointments in the calendar. Keep running this code daily for a week - if all is good. I'd love my answer accepted. Thanks.
0
 

Author Comment

by:dond123
ID: 33622583
PhilAI,

Your solution (along with instructing the users to make sure to open Outlook on the server before running the code) seems to have resolved the issue.  I think it was a combination of the code and having Outlook opened based upon some additional information I found online.

Thanks,
0

Featured Post

Get free NFR key for Veeam Availability Suite 9.5

Veeam is happy to provide a free NFR license (1 year, 2 sockets) to all certified IT Pros. The license allows for the non-production use of Veeam Availability Suite v9.5 in your home lab, without any feature limitations. It works for both VMware and Hyper-V environments

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
This article will help to fix the below error for MS Exchange server 2010 I. Out Of office not working II. Certificate error "name on the security certificate is invalid or does not match the name of the site" III. Make Internal URLs and External…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

722 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question