Listing 2: The ProcessResponses() Subroutine
NONEXECUTABLE: To obtain the executable file, download the .zip file from the opening page of the article.

Sub ProcessResponses()
    Dim objApp As Application
    Dim objNS As NameSpace
    Dim colInbox As Items
    Dim objItem As Object
    Dim intProcessed As Integer
    Dim strMsg As String
    Dim strWhere As String
    Dim colDiscards As Items
   
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set colInbox = objNS.GetDefaultFolder(olFolderInbox).Items

    For Each objItem In colInbox
        ' check the class and process if appropriate
        Select Case objItem.Class
            Case olReport
                If UCase(objItem.MessageClass) = "REPORT.IPM.NOTE.DR" Or _
                  UCase(objItem.MessageClass) = "REPORT.IPM.NOTE.IPNRN" Then
                    Call DoProcess(objItem)
                End If
            Case olMail
                If objItem.VotingResponse <> "" Then
                    Call DoProcess(objItem)
                End If
        End Select
    Next
   
    ' remove processed items
    strWhere = "[BillingInformation]=" & AddQuote("Discard")
    Set colDiscards = colInbox.Restrict(strWhere)
    Debug.Print colDiscards.Count
    While colDiscards.Count > 0
        colDiscards.Remove 1
    Wend

    Set objApp = Nothing
    Set objNS = Nothing
    Set colInbox = Nothing
    Set objItem = Nothing
    Set colDiscards = Nothing
End Sub

Sub DoProcess(objItem As Object)
    With objItem
        .Display
        .BillingInformation = "Discard"
        .Close olSave
    End With
End Sub

Function AddQuote(MyText) As String
    AddQuote = Chr$(34) & MyText & Chr$(34)
End Function