VBA – Processing ICS calendar file attachments

Posted on Wednesday, July 27th, 2011 at 8:20 pm in

This article brings to conclusion the Outlook VBA macro/script I wrote to process event scheduling attachments (.ICS or ICalendar files). The first article shows how to process emails and remove their associated attachments. The second shows how to open the files and both read the file contents into an array as well as write (append) to the file. This code works in Outlook 2007.

The script does the following:

1. Check if the email has an attachment
2. If the attachment is an ICalendar (.ICS) file, remove it to a common folder and update the email with a link to the detached file.
3. Loop through the ICS files in the designated folder and load them into an array.
4. If the last element in the array contains the value “PROCESSED”, skip it
5. Take the UID (Unique IDentifier) array element and turn it into an Outlook Event GUID.
6. Check if there are any events which have the UID Guid. If there are, this indicates the new file is an update to a previously processed event.
7. If there is no previous event with the UID Guid, add the event using the UID Guid as an identifier.
8. If there is a previous event and the new notice is a cancellation, delete the event.
9. If there is a previous event and the new notice is not a cancellation, update the event.
10. Append a line to the ICS file with the value “PROCESSED”.

Public Sub SaveICSAttachmentsMacro()
    Dim objOL As Outlook.Application
    Dim objitem As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String
    Dim strArray() As String 
    Dim ac As Long
    Dim lSeq As Long
    Dim lPriority As Long
    Dim strLine As String
    Dim strField As String
    Dim strValue As String
    Dim strMethod As String
    Dim strUid As String
    Dim strSummary As String
    Dim strLocation As String
    Dim strDesc As String
    Dim strOrganizer As String
    Dim strDate As String
    Dim dtStart As Date
    Dim dtEnd As Date
     Dim hexUID
    ' Instantiate an Outlook Application object.
    Set objOL = Application
     Dim objNs As Outlook.NameSpace
     Set objNs = objOL.Session
     Dim objFolder As Outlook.MAPIFolder
     Set objFolder = objNs.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
     Dim objAppts As Outlook.Items
     Set objAppts = objFolder.Items
     Dim objAppt As Outlook.AppointmentItem
     Dim strFilter As String
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
'[snip] see code from Removing attachments post
    ' call function in different module
    ' this populates the string array from the iCalendar file
    icsFileToArray strFile, strArray
    ' check last element of array to determine if file previously processed
    If strArray(UBound(strArray)) = "PROCESSED" Then
        'file already processed
        GoTo ExitSub
        ' loop through array to process event
        For ac = 1 To UBound(strArray)
            ' separate data pairs
            strLine = strArray(ac)
            If InStr(1, strLine, ":") > 0 Then
                strField = Mid(strLine, 1, InStr(1, strLine, ":") - 1)
                strValue = Mid(strLine, InStr(1, strLine, ":") + 1)
            End If
            Select Case strField
                Case "METHOD"
                 ' REQUEST or CANCEL
                    strMethod = strValue
                Case "UID"
                 ' Unique identifier for event
                    strUid = strValue
                Case "DTSTART"
                    ' pull out values into 'mm/dd/yyyy hh:mm:ss' format
                    strDate = (Mid(strValue, 5, 2) & "/" & Mid(strValue, 7, 2) & _
                    "/" & Mid(strValue, 1, 4) & " " & Mid(strValue, 10, 2) & ":" & _
                    Mid(strValue, 12, 2))
                    dtStart = CDate(strDate)
                    ' put datetime into Outlook format
                    dtStart = Format(dtStart, "\#m\/d\/yyyy h:mm:ss AM/PM\#")
                Case "DTEND"
                    ' pull out values into 'mm/dd/yyyy hh:mm:ss' format
                    strDate = (Mid(strValue, 5, 2) & "/" & Mid(strValue, 7, 2) & _
                    "/" & Mid(strValue, 1, 4) & " " & Mid(strValue, 10, 2) & ":" & _
                    Mid(strValue, 12, 2))
                    dtEnd = CDate(strDate)
                    dtEnd = Format(dtEnd, "\#m\/d\/yyyy h:mm:ss AM/PM\#")
                Case "SUMMARY"
                    strSummary = strValue
                Case "LOCATION"
                    strLocation = strValue
                Case "ORGANIZER"
                    ' can not set this as of 6-30-2011
                    strOrganizer = strValue
                Case "PRIORITY"
                    lPriority = Val(strValue)
                Case "SEQUENCE"
                 ' if an update must be > 0
                    lSeq = Val(strValue)
                Case "DESCRIPTION"
                    strDesc = strValue
                Case Else
            End Select
    End If
    ' check if appointment already exists for given UID
    'convert UID to hex. this should match the GlobalAppointmentID if the item was
    ' imported manually
    'Start with the standard preamble (original example had 26 and not 12 here)=======vv
    hexUID = "040000008200E00074C5B7101A82E0080000000000000000000000000000000000000000120000007643616C2D55696401000000"
    'Now add the provided string
    For i = 1 To Len(strUid)
        hexUID = hexUID & CStr(Hex(Asc(Mid(strUid, i, 1))))
    'Terminate the UID
    hexUID = hexUID & "00"
    ' this filter used if the new field is set to the GlobalAppointmentID
    strFilter = "[UID] = '" & hexUID & "'"
    Set objAppt = objAppts.Find(strFilter)
    If objAppt Is Nothing Then
        'New event
         Dim myItem As Outlook.AppointmentItem
         Set myItem = objOL.CreateItem(olAppointmentItem)
         myItem.Start = dtStart
         myItem.End = dtEnd
         myItem.Subject = strSummary
         myItem.Location = strLocation
         myItem.Body = strDesc
	 ' this was not working when I did this
         ' myItem.Organizer = strOrganizer
	 ' add a new property "UID" to the event so it can be updated
         myItem.ItemProperties.Add "UID", olText, True
         myItem.ItemProperties.Item("UID").Value = hexUID
        If strMethod = "CANCEL" Then
            ' remove item from calendar
        ElseIf lSeq > 0 Then
            ' update must have sequence > 0
            objAppt.Start = dtStart
            objAppt.End = dtEnd
            objAppt.Subject = strSummary
            objAppt.Location = strLocation
            objAppt.Body = strDesc
        End If
    End If
    ' mark file processed
    icsWriteToFile strFile

Set objAttachments = Nothing
Set objitem = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

The biggest issue I came across in dealing with Outlook is the ability to update or delete a previously scheduled event. One would think Microsoft could handle the setting of an ID which could then be used to find it consistently. Outlook does assign an ID to events but these get changed if you move them around. The ‘GlobalAppointmentID’ does get set (as a GUID) and remains constant but you have no way of searching for it (sigh). Anyway I get around this by adding a property to any Event created via this process and assign the UID (which is converted into a GUID) to it. This way I can do a simple ‘Find’ of my apppointments and process appropriately. Here are some links related to GUIDs and Outlook

MSDN Outlook GUID stuff

Changing a string into an Outlook Event GUID See answer by banjaxed.

Note this process does not handle recurring appointments

You might also be interested in

Add your comment

Leave a Reply