Getting 'Out Of Office' status of an incoming email using VBA in Excel.

[Darren Bartrup]

Afternoon all,

I'm trying to write some code in Excel 2010 which will report on the contents of a selected folder within Outlook 2010 - total emails, emails that have been replied to, forwarded emails and out of office emails.

I've got the replied to and forwarded parts sorted, but I can't figure out how to get the Out Of Office status of an email other than reading the subject line to see if it says 'Out of Office' (which it doesn't always say anyway).

The code I've written is in two modules and I was hoping to get the OOO status from either the PR_LAST_VERB_EXECUTED or PR_TRANSPORT_MESSAGE_HEADERS values, but can't find it anywhere.

A normal module:

Public Const PR_CLIENT_SUBMIT_TIME = "http://schemas.microsoft.com/mapi/proptag/0x00390040"
Public Const PR_LAST_VERB_EXECUTED = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
Public Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Public ColCellValues As Collection


'----------------------------------------------------------------------------------
' Procedure : CreateReport
' Author    : Darren Bartrup-Cook
' Date      : 08/12/2014
' Purpose   : Asks the user to selected the folder to look at.
'-----------------------------------------------------------------------------------
Public Sub CreateReport()


    Dim oOutlook As Object          'Outlook.Application
    Dim nNameSpace As Object        'Outlook.Namespace
    Dim mFolderSelected As Object   'Outlook.MAPIFolder
    Dim oItem As Object
    Dim rLastCell As Range
    Dim x As Long
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'ColCellValues will hold a reference to each cell in the report,   '
    'each cell being made up of a class instance containing seperated '
    'data                                                             '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set ColCellValues = New Collection
    
    '''''''''''''''''''''''''''''
    'Set references to Outlook. '
    '''''''''''''''''''''''''''''
    Set oOutlook = GetObject(, "Outlook.Application")
    Set nNameSpace = oOutlook.GetNamespace("MAPI")
    
    ''''''''''''''''''''''''''''''''''''''''''''''
    'Ask the user to select the folder to count. '
    ''''''''''''''''''''''''''''''''''''''''''''''
    Set mFolderSelected = nNameSpace.PickFolder
    
    '''''''''''''''''''''''''''''''''''''''''
    'Clear the contents of the spreadsheet. '
    '''''''''''''''''''''''''''''''''''''''''
    shtAnalysis.Cells.Delete Shift:=xlUp
    
    ProcessFolder mFolderSelected


End Sub


'----------------------------------------------------------------------------------
' Procedure : ProcessFolder
' Author    : Darren Bartrup-Cook
' Date      : 08/12/2014
' Purpose   : Cycles through each email in the selected folder and all subfolders.
'-----------------------------------------------------------------------------------
Private Sub ProcessFolder(oParent As Object)


    Dim oFolder As Object 'Outlook.MAPIFolder
    Dim oMail As Object
    Dim sName As String


    On Error Resume Next
    For Each oMail In oParent.Items
        RecordDetails oMail, oParent
    Next oMail
    
    If (oParent.Folders.Count > 0) Then
        For Each oFolder In oParent.Folders
            ProcessFolder oFolder
        Next oFolder
    End If
    On Error GoTo 0


End Sub


'----------------------------------------------------------------------------------
' Procedure : RecordDetails
' Author    : Darren Bartrup-Cook
' Date      : 08/12/2014
' Purpose   : Decides what type of email is being looked at.
'-----------------------------------------------------------------------------------
Public Sub RecordDetails(oMail As Object, oFolders As Object)


    Dim dDate As Date
    Dim lRow As Long, lCol As Long
    Dim rDateCell As Range, rFolderCell As Range
    Dim sFolder As String
    Dim lFolderLevel As Long
    Dim x As Long
    Dim clsCell As clsCellValue
    Dim sKey As String
    
    Dim PropertyAccessor As Object
    Dim vSubmitTime As Variant
    Dim vStatus As Variant
    Dim vHeader As Variant


    With shtAnalysis
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'First find the row number and column number that the data needs placing in. '
        'The cell reference is also the collection key.                              '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'Find the row number the date falls on.               '
        'If the date can't be found then add it to a new row. '
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''
        dDate = Int(oMail.SentOn)
        Set rDateCell = .Columns("A:A").Cells.Find( _
            What:=dDate, _
            After:=.Cells(2, 1), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchDirection:=xlNext)
        If Not rDateCell Is Nothing Then
            lRow = rDateCell.Row
        Else
            lRow = LastCell(shtAnalysis).Row + 1
        End If
        Set rDateCell = Nothing
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'Format the folder name to match as it would appear on the sheet. '
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        sFolder = oFolders.FullFolderPath
        If Left(sFolder, "2") = "\\" Then
            sFolder = Mid(sFolder, 3, Len(sFolder))
        End If
        lFolderLevel = Len(sFolder) - Len(Replace(sFolder, "\", ""))
        For x = 1 To lFolderLevel
            sFolder = Left(sFolder, InStr(sFolder, "\") - 1) & _
                Replace(sFolder, "\", Chr(10) & _
                Application.WorksheetFunction.Rept(" ", x) & Chr(149), InStr(sFolder, "\"), 1)
        Next x
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'Find the column number on row 1.                           '
        'If the heading can't be found then add it to a new column. '
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Set rFolderCell = .Rows("1:1").Cells.Find( _
            What:=sFolder, _
            After:=.Cells(1, 1), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchDirection:=xlNext)
        If Not rFolderCell Is Nothing Then
            lCol = rFolderCell.Column
        Else
            lCol = LastCell(shtAnalysis).Column + 1
        End If
        Set rFolderCell = Nothing
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'The collection key is made up of the row and column number. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        sKey = Replace(.Cells(lRow, lCol).Address, "$", "")
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'If the cell range is not already an item in the collection  '
        'then add it.                                                '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If Not IsInCollection(sKey) Then
        
            '''''''''''''''''''''''''''''''''''''''''''''''''
            'Add the folder name and date to the worksheet. '
            '''''''''''''''''''''''''''''''''''''''''''''''''
            .Cells(1, Range(sKey).Column) = sFolder
            .Cells(Range(sKey).Row, 1) = dDate
        
            ''''''''''''''''''''''''''''''''''''''''
            'Create a class instance for the cell. '
            ''''''''''''''''''''''''''''''''''''''''
            Set clsCell = New clsCellValue
            clsCell.CellLocation = shtAnalysis.Range(sKey)
            ColCellValues.Add clsCell, sKey
            Set clsCell = Nothing
        End If
                
        ''''''''''''''''''''''''''''''''
        'Get date and status of email. '
        ''''''''''''''''''''''''''''''''
        Set PropertyAccessor = oMail.PropertyAccessor
        vSubmitTime = PropertyAccessor.getproperty(PR_CLIENT_SUBMIT_TIME)
        vStatus = PropertyAccessor.getproperty(PR_LAST_VERB_EXECUTED)
        vHeader = PropertyAccessor.getproperty(PR_TRANSPORT_MESSAGE_HEADERS)
        
        
        
        With ColCellValues(sKey)
            .TotalEmails = 1
            Select Case vStatus
            
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                'EXCHIVERB_REPLYTOSENDER = 102, EXCHIVERB_REPLYTOALL = 103 '
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                Case 102, 103
                    .RepliedEmails = 1
                    
                ''''''''''''''''''''''''''
                'EXCHIVERB_FORWARD = 104 '
                ''''''''''''''''''''''''''
                Case 104
                    .ForwardEmails = 1
                
            End Select
        End With
    
        ColCellValues(sKey).CellLocation.Value = "Total Emails: " & ColCellValues(sKey).TotalEmails
    End With
        
    Debug.Assert False


End Sub


Public Function IsInCollection(sKey As String) As Boolean


Dim bTest As Boolean


    On Error Resume Next
    
    bTest = IsObject(ColCellValues(sKey))
    
    IsInCollection = (Err = 0)
    Err.Clear


End Function

And a class module called clsCellValue:

Private sCellValue As StringPrivate rLocation As Range
Private lTotalEmails As Long
Private lRepliedEmails As Long
Private lForwardEmails As Long
Private lOutOfOffice As Long


Public Property Let CellLocation(Address As Range)
    Set rLocation = Address
End Property


Public Property Get CellLocation() As Range
    Set CellLocation = rLocation
End Property


Public Property Let OutOfOffice(Value As Long)
    lOutOfOffice = lOutOfOffice + Value
End Property


Public Property Get OutOfOffice() As Long
    OutOfOffice = lOutOfOffice
End Property


Public Property Let TotalEmails(Value As Long)
    lTotalEmails = lTotalEmails + Value
End Property


Public Property Get TotalEmails() As Long
    TotalEmails = lTotalEmails
End Property


Public Property Let RepliedEmails(Value As Long)
    lRepliedEmails = lRepliedEmails + Value
End Property


Public Property Get RepliedEmails() As Long
    RepliedEmails = lRepliedEmails
End Property


Public Property Let ForwardEmails(Value As Long)
    lForwardEmails = lForwardEmails + Value
End Property


Public Property Get ForwardEmails() As Long
    ForwardEmails = lForwardEmails
End Property

Any help is greatly appreciated as usual.