After my previous post

I decided to continue development and hence today I present to you an approach to searching for appointments. The beauty here is once you implement this type of framework you can then easily:

• Find Outlook Appointment and Save them to disk
• Find Outlook Appointment and Display them to the user for their interaction
• Find Outlook Appointment and Update them and then save the changes
• Find Outlook Appointment and Delete them.
• You could retrieve the items to display in a form for user interaction
• …

Furthermore, such a Framework can be applied to just about any Outlook Items:

• Mail
• Contacts
• Appointments
• …

In the example code below, I am saving the filtered items to disk.

So, in this code I provide conditional compilation to enable both Early and Late Binding, so the choice is yours!  Of course, if we are to use Late Binding, we need to set up some Enums to facilitate coding and then there are a couple general helper functions as well.

Helper Functions

'---------------------------------------------------------------------------------------
' Procedure : SanitizeFileNameString
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Sanitize the supplied string to follow Windows file naming conventions
'               ie: avoid illegal characters
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding  -> none required
' References: https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInput    : filename to validate/sanitize
'
' Usage:
' ~~~~~~
' SanitizeFileNameString("some file > ?")
'   Returns -> some file _ _
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2001-11-09
' 2         2024-01-09              Updated header and added References link
'---------------------------------------------------------------------------------------
Public Function SanitizeFileNameString(sInput As String) As String
On Error GoTo Error_Handler
    Dim sOutput               As String
    Const sReplacementChr     As String = "_" 'Could be a function Input Arg.
    
    sOutput = sInput

    ' Windows naming convention
    sOutput = Replace(sOutput, "<", sReplacementChr)
    sOutput = Replace(sOutput, ">", sReplacementChr)
    sOutput = Replace(sOutput, ":", sReplacementChr)
    sOutput = Replace(sOutput, """", sReplacementChr)
    sOutput = Replace(sOutput, "/", sReplacementChr)
    sOutput = Replace(sOutput, "\", sReplacementChr)
    sOutput = Replace(sOutput, "|", sReplacementChr)
    sOutput = Replace(sOutput, "?", sReplacementChr)
    sOutput = Replace(sOutput, "*", sReplacementChr)
    
    ' Personal convention
    'sOutput = Replace(sOutput, "'", sReplacementChr)
    'sOutput = Replace(sOutput, " ", sReplacementChr)
    sOutput = Replace(sOutput, ".", sReplacementChr)

    SanitizeFileNameString = sOutput
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Source: SanitizeFileNameString" & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

Public Function GetSaveAsTypeExtension(ByVal lSaveAsFormat As OlSaveAsType, _
                                       Optional bIncludePeriod As Boolean = False) As String
    Dim sOutput               As String

    Select Case lSaveAsFormat
        Case 0
            sOutput = "txt"
        Case 1
            sOutput = "rtf"
        Case 2
            sOutput = "oft"
        Case 3
            sOutput = "msg"
        Case 4
            sOutput = "doc"
        Case 5
            sOutput = "html"
        Case 6
            sOutput = "vcf"
        Case 7
            sOutput = "vcs"
        Case 8
            sOutput = "ics"
        Case 9
            sOutput = "msg"
        Case 10
            sOutput = "mht"
    End Select
    If bIncludePeriod Then sOutput = "." & sOutput
    GetSaveAsTypeExtension = sOutput
End Function

Enum

#If Outlook_EarlyBind = False Then
    Enum OlDefaultFolders
        'https://learn.microsoft.com/en-us/office/vba/api/outlook.oldefaultfolders
        '   *** There are more elements to this Enum, see link above for complete listing
        olFolderUnspecified = 0
        olFolderDeletedItems = 3
        olFolderOutbox = 4
        olFolderSentMail = 5
        olFolderInbox = 6
        olFolderDrafts = 16
        olFolderJunk = 23
        
        olFolderCalendar = 9
        olFolderConflicts = 19
        olFolderContacts = 10
        olFolderJournal = 11
        olFolderLocalFailures = 21
        olFolderManagedEmail = 29
        olFolderNotes = 12
        olFolderServerFailures = 22
        olFolderSuggestedContacts = 30
        olFolderSyncIssues = 20
        olFolderTasks = 13
        olFolderToDo = 28
        olPublicFoldersAllPublicFolders = 18
        olFolderRssFeeds = 25
    End Enum
    
    Enum OlObjectClass
        'https://learn.microsoft.com/en-us/office/vba/api/outlook.olobjectclass
        olObjectClassUnspecified = 0
        olContact = 40
        olMail = 43
        olAppointment = 26
        olJournal = 42
        olNote = 44
        olTask = 48
    End Enum
    
    Enum OlSaveAsType
        'https://learn.microsoft.com/en-us/office/vba/api/Outlook.OlSaveAsType
        olDoc = 4
        olHTML = 5
        olICal = 8
        olMHTML = 10 'Not in the contact saveas method?
        olMSG = 3
        olMSGUnicode = 9
        olRTF = 1
        olTemplate = 2
        olTXT = 0
        olVCal = 7
        olVCard = 6
    End Enum
#End If

Core Code

#Const Outlook_EarlyBind = 0 '0 => Late Binding
                             '-1 => Early Binding which requires a Ref to 'Microsoft Outlook XX.X Object Library'

'Searches the specified folder ,and, optionally, process subfolders as well
Sub Outlook_FindAndSave_Advanced(Optional sFilter As String, _
                                 Optional bProcessSubFolders As Boolean = False, _
                                 Optional sSaveFolder As String, _
                                 Optional lFolder As OlDefaultFolders, _
                                 Optional sSubFolder As String, _
                                 Optional lSaveAsFormat As OlSaveAsType = olVCard)
#If Outlook_EarlyBind Then
    Dim oOutlook              As Outlook.Application
    Dim oNS                   As Outlook.NameSpace
    Dim oFolder               As Outlook.MAPIFolder
#Else
    Dim oOutlook              As Object
    Dim oNS                   As Object
    Dim oFolder               As Object
#End If
    Dim bOutlookOpened        As Boolean
    Dim sExtension As String
    Dim aFolders() As String
    Dim i As Long

    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    If Err.Number <> 0 Then    'Could not get instance of Outlook, so create a new one
        Err.Clear
        #If Outlook_EarlyBind Then
            Set oOutlook = New Outlook.Application
        #Else
            Set oOutlook = CreateObject("Outlook.Application")
        #End If
        bOutlookOpened = False    'Outlook was not already running, we had to start it
    Else
        bOutlookOpened = True    'Outlook was already running
    End If

    On Error GoTo Error_Handler
    DoEvents

    Set oNS = oOutlook.GetNamespace("MAPI")
    'Bind to the root folder to process messages in
    If lFolder = olFolderUnspecified Then
        lFolder = olFolderInbox    'Default it to the Inbox
    End If

    Set oFolder = oNS.GetDefaultFolder(lFolder)
    
    If sSubFolder <> "" Then
        'Break the subfolders into individual subfolders
        aFolders = Split(sSubFolder, "\")
        'Iterate over each subfolder to set the initial starting point
        For i = 0 To UBound(aFolders)
            If Len(Trim(aFolders(i) & "")) > 0 Then
                Set oFolder = oFolder.Folders(aFolders(i))
            End If
        Next i
    End If
    
    sExtension = GetSaveAsTypeExtension(lSaveAsFormat, True)

    'Begin the e-mail message search/filter and save process
    Call Outlook_FindAndSaveInFolder(oFolder, sFilter, bProcessSubFolders, sSaveFolder, lSaveAsFormat, sExtension)

    If bOutlookOpened = False Then    'Since we started Outlook, we should close it now that we're done
        oOutlook.Quit    'There seems to be a delay in this action taking place, but does eventually take place
    End If

Error_Handler_Exit:
    On Error Resume Next
    Set oFolder = Nothing
    Set oNS = Nothing
    Set oOutlook = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Outlook_FindAndSave_Advanced" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub

#If Outlook_EarlyBind Then
Sub Outlook_FindAndSaveInFolder(ByVal oFolder As Outlook.MAPIFolder, _
                                sFilter As String, _
                                Optional bProcessSubFolders As Boolean = False, _
                                Optional sSaveFolder As String, _
                                Optional lSaveAsFormat As OlSaveAsType = olVCard, _
                                Optional sExtension As String = "vcf")
#Else
Sub Outlook_FindAndSaveInFolder(ByVal oFolder As Object, _
                                sFilter As String, _
                                Optional bProcessSubFolders As Boolean = False, _
                                Optional sSaveFolder As String, _
                                Optional lSaveAsFormat As OlSaveAsType = olVCard, _
                                Optional sExtension As String = "vcf")
#End If
                                
    On Error GoTo Error_Handler
    #If Outlook_EarlyBind Then
        Dim oFilterItems          As Outlook.Items
        Dim oSubFldr              As Outlook.MAPIFolder
    #Else
        Dim oFilterItems          As Object
        Dim oSubFldr              As Object
    #End If
    Dim oFilterItem           As Object
    Dim sFileName             As String
    'https://learn.microsoft.com/en-us/office/vba/api/outlook.olobjectclass
    'Const olAppointment = 26

    'Apply our search criteria ir applicable
    If sFilter = "" Then
        Set oFilterItems = oFolder.Items
    Else
        Set oFilterItems = oFolder.Items.Restrict(sFilter)
    End If

    'Apply a sort, not necessary for our purposes but left if using for general search purposes
    'oFilterItems.Sort "[SentOn]", True    'Sort the results, Descending order (True)

    'Set the Folder to save the files to
    If sSaveFolder = "" Then
        sSaveFolder = Application.CurrentProject.Path & "\emails\"
    End If
    If Right(sSaveFolder, 1) <> "\" Then sSaveFolder = sSaveFolder & "\"

    'Debug.Print "Saving " & oFilterItems.Count & " messages to disk."
    'Iterate over the matching items and save them to disk
    For Each oFilterItem In oFilterItems
        If oFilterItem.Class = olAppointment Then  'olContact
            'Build a File Name to save the msg under
            sFileName = sSaveFolder
            'sFileName = sFileName & oFilterItem.EntryId
            sFileName = sFileName & Format(oFilterItem.Start, "yyyymmddhhnnss")
            sFileName = sFileName & "_"
            sFileName = sFileName & SanitizeFileNameString(oFilterItem.Subject) & sExtension
            'https://learn.microsoft.com/en-us/office/vba/api/outlook.contactitem.saveas
            oFilterItem.SaveAs sFileName, lSaveAsFormat
        End If
        DoEvents
    Next

    'Process any SubFolders
    If bProcessSubFolders Then
        If oFolder.Folders.Count > 0 Then
            For Each oSubFldr In oFolder.Folders
                'Debug.Print "Processing Folder: " & oSubFldr.Name
                Call Outlook_FindAndSaveInFolder(oSubFldr, sFilter, bProcessSubFolders)
                DoEvents
            Next
        End If
    End If

Error_Handler_Exit:
    On Error Resume Next
    Set oSubFldr = Nothing
    Set oFilterItem = Nothing
    Set oFilterItems = Nothing
    Set oFolder = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Outlook_FindAndSaveInFolder" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub

Usage

To use the above we could do something like:

Dim sFilter               As String
sFilter = "[Organizer]='Jane Doe'"

Call Outlook_FindAndSave_Advanced(sFilter, , , olFolderCalendar, , olTXT)

which will find all the meetings where ‘Jane Doe’ is the Organizer and export them as txt files.

Dim sFilter               As String
sFilter = "[Start]='1/16/2024 1:30 PM'"

Call Outlook_FindAndSave_Advanced(sFilter, , , olFolderCalendar, , olVCal)

which will export any appointments starting at 1:30 PM on January 16th, 2024 as vcal format (vcs files).

And you can combine filters as you see fit by using the standard And & OR

Dim sFilter               As String

sFilter = "[Organizer]='Jane Doe'"
sFilter = sFilter & " AND "
sFilter = "[Start]>'1/1/2023 0:00 AM'"

Call Outlook_FindAndSave_Advanced(sFilter, , , olFolderCalendar, , olVCal)

which will export all the meetings organized by ‘Jane Doe’ after ‘1/1/2023 0:00 AM’.

Changing the Default Action

The current code uses the line

oFilterItem.SaveAs sFileName, lSaveAsFormat

to save the item(s) to disk. So you need only override this line to change the action to be taken with matching item. For instance, if you wanted to open the item(s) you could replace that line with

oFilterItem.Display

and now any matching calendar items will be opened instead of saved to disk.