Outlook Appointment Categorizer

Option Explicit

Private Sub Application_Reminder(ByVal Item As Object)

    If Item.MessageClass <> "IPM.Appointment" Then
      Exit Sub
    End If

    Dim Appt As AppointmentItem
    Dim Items As Object

    Set Items = Session.GetDefaultFolder(olFolderCalendar).Items

    For Each Appt In Items

        On Error Resume Next

        If InStr(Appt.Subject, "Trip - KW") > 0 Or _
           InStr(Appt.Subject, "Hotel - ") > 0 Or _
           InStr(Appt.Subject, "Car Pick-Up") > 0 Or _
           InStr(Appt.Subject, "Car Drop-Off") > 0 Or _
           InStr(Appt.Subject, "Abreise") > 0 Or _
           InStr(Appt.Subject, "Anreise") > 0 Or _
           InStr(Appt.Subject, "Flight AB") > 0 Or _
           InStr(Appt.Subject, "Flight LH") > 0 Then

            If InStr(Appt.Categories, "Reise") = 0 Then
                Appt.Categories = "Reise;" & Appt.Categories
                Appt.Save
            End If
        End If

        If InStr(Appt.Subject, "WW Communities") > 0 Or _
           InStr(Appt.Subject, "Invite - ") > 0 Then

            If InStr(Appt.Categories, "20_Orga/Learning") = 0 Then
                Appt.Categories = "20_Orga/Learning;" & Appt.Categories
                Appt.Save
            End If
        End If

    Next

    Beep


End Sub



Public Sub remove_extension()

    Dim app As Outlook.Application
    Set app = CreateObject("Outlook.Application")

    Dim ns As Outlook.NameSpace
    Set ns = app.GetNamespace("MAPI")
    ns.Logon

    Dim contacts As Outlook.MAPIFolder
    Set contacts = ns.GetDefaultFolder(olFolderContacts)

    Dim Item As Outlook.ContactItem
    Dim sDisplayAs As String
        Dim rx As New RegExp
    rx.IgnoreCase = True
    rx.Pattern = "\s*X\d+"

    For Each Item In contacts.Items
        Dim s As String
        s = rx.Replace(Item.BusinessTelephoneNumber, "")
        If (s <> Item.BusinessTelephoneNumber) Then
            Item.BusinessTelephoneNumber = s
            Item.Save
        End If

    Next
    Beep
End Sub


Public Sub format_display_name()

    Dim app As Outlook.Application
    Set app = CreateObject("Outlook.Application")

    Dim ns As Outlook.NameSpace
    Set ns = app.GetNamespace("MAPI")
    ns.Logon

    Dim contacts As Outlook.MAPIFolder
    Set contacts = ns.GetDefaultFolder(olFolderContacts)

    Dim Item As Outlook.ContactItem
    Dim sDisplayAs As String

    For Each Item In contacts.Items

        sDisplayAs = ""

        If (Len(Item.FirstName) * Len(Item.LastName) > 0) Then
            sDisplayAs = Item.LastName + ", " + Item.FirstName
        Else
            sDisplayAs = Item.FileAs
        End If

        If Item.CompanyName = "GERMANY" Then
            sDisplayAs = sDisplayAs + " (Microsoft)"
            Item.CompanyName = "Microsoft"
        ElseIf Len(Item.CompanyName) > 0 Then
            sDisplayAs = sDisplayAs + " (" + Item.CompanyName + ")"
        End If


        If (Len(sDisplayAs) > 0) Then
            Item.Email1DisplayName = sDisplayAs
            Item.Save
        End If

    Next
    Beep
 End Sub