Help with VBA coding for coloring calendar events RRS feed

  • Question

  • Hi Everyone,

    So here is the basic need of mine.  I send out calendar invites for meetings all the time, but can't keep track with the sheer volume that I have every week.  That means every day I come in to the office I have to open every calendar entry for the day to see if someone has accepted, denied, or just hasn't responded yet to then close, delete, and remind respectively.

    So what I want is for accepted appointments to be green, yet to respond appointments to be yellow, and declined invites to be red.  If a meeting has more than one attendee and mixed responses then I would like those to be colored Orange.

    A dev responded to me on another forum saying it needed to be done in VBA but I'm not a programmer so any help with this is greatly appreciated!
    Monday, October 28, 2013 12:30 PM


  • Hi,

    Thanks for posting on MSDN forum.

    According to your description, you want to set the color for the appointment base on the response status.
    You can set the color for appointment by setting the Category.
    I wrote a sample for your reference, if you renamed the categories before, you need to adjust the code a little. The code will run when you start the Outlook, if you want to refresh the color, you can click the macro like figure below:

    You can press Alt+F11 to open VBEdit and copy the code to ThisOutlookSession:

    Sub SetAppointmentColor()
    Dim olApp As Outlook.Application
    Dim olFolder As Outlook.folder
    Dim olItems As Outlook.Items
    Dim olItem As Outlook.AppointmentItem
    Dim strText As String
    Dim bStarted As Boolean
    Dim i As Long
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
         Set olApp = CreateObject("Outlook.Application")
         bStarted = True
    End If
     Set olFolder = olApp.Session.GetDefaultFolder(olFolderCalendar)
    Set olItems = olFolder.Items
    For i = olItems.Count To 1 Step -1
         Set olItem = olItems(i)
         Dim acceptedCount As Integer, notResponedCount As Integer, tentativelyAcceptedCount As Integer, declineCount As Integer, responseStatus As Integer
         acceptedCount = 0
         notResponedCount = 0
         tentativelyAcceptedCount = 0
         declineCount = 0
         responseStatus = 0
         If olItem.Subject = "test1" Then
         For j = 0 To olItem.Recipients.Count
            If olItem.Recipients.Item(j).name <> olItem.Organizer Then
               Select Case olItem.Recipients.Item(j).MeetingResponseStatus
               Case olResponseAccepted
                  acceptedCount = acceptedCount + 1
               Case olResponseNone
                   notResponedCount = notResponedCount + 1
               Case olResponseNotResponded
                  notResponedCount = notResponedCount + 1
               Case olResponseTentative
                  'tentativelyAcceptedCount = tentativelyAcceptedCount + 1
                  acceptedCount = acceptedCount + 1
               Case olResponseDeclined
                   declineCount = declineCount + 1
               End Select
            End If
         Next j
             End If
       ' set default
       responseStatus = 10000
         If acceptedCount + 1 = olItem.Recipients.Count Then
            responseStatus = olResponseAccepted
         End If
         If declineCount + 1 = olItem.Recipients.Count Then
             responseStatus = olResponseDeclined
         End If
        If acceptedCount + declineCount = 0 Then
            responseStatus = olResponseNotResponded
        End If
         'if you rename the catagory before, you need change to the corresponding name
         Select Case responseStatus
         Case olResponseAccepted
            olItem.Categories = "Green Category"
         Case olResponseNotResponded
            olItem.Categories = "Yellow Category"
         Case olResponseDeclined
            olItem.Categories = "Red Category"
         Case Else
            olItem.Categories = "Orange Category"
        End Select
    Next i
    Set olApp = Nothing
    Set olFolder = Nothing
    Set olItems = Nothing
    Set olItem = Nothing
    End Sub
    Private Sub Application_Startup()
    End Sub

    Best regards


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Thursday, October 31, 2013 3:25 AM