Solved

Looping through Outlook Calendar Items in VBA (MS Access)

Posted on 2010-08-18
16
1,747 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
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
Migrating Your Company's PCs

To keep pace with competitors, businesses must keep employees productive, and that means providing them with the latest technology. This document provides the tips and tricks you need to help you migrate an outdated PC fleet to new desktops, laptops, and tablets.

 
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 125 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

VMware Disaster Recovery and Data Protection

In this expert guide, you’ll learn about the components of a Modern Data Center. You will use cases for the value-added capabilities of Veeam®, including combining backup and replication for VMware disaster recovery and using replication for data center migration.

Question has a verified solution.

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

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…
This article lists the top 5 free OST to PST Converter Tools. These tools save a lot of time for users when they want to convert OST to PST after their exchange server is no longer available or some other critical issue with exchange server or impor…
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …

770 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