Solved

Looping through Outlook Calendar Items in VBA (MS Access)

Posted on 2010-08-18
16
1,648 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
  • 9
  • 6
16 Comments
 
LVL 6

Expert Comment

by:PhilAI
Comment Utility
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
Comment Utility
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
Comment Utility
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
 
LVL 2

Expert Comment

by:larkvale
Comment Utility

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
Comment Utility
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 125 total points
Comment Utility
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
Comment Utility
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
Comment Utility
I noticed that. And tested it with recurrences also. Even created a recurrence that got picked up. And it still works!?
0
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 6

Expert Comment

by:PhilAI
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
0
 
LVL 6

Expert Comment

by:PhilAI
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

If you don't know how to downgrade, my instructions below should be helpful.
This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
Familiarize people with the process of retrieving data from SQL Server using an Access pass-thru query. Microsoft Access is a very powerful client/server development tool. One of the ways that you can retrieve data from a SQL Server is by using a pa…
Basics of query design. Shows you how to construct a simple query by adding tables, perform joins, defining output columns, perform sorting, and apply criteria.

772 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now