Outlook Email Approval tracker?

[nindisp]

Hi - I'm wondering if there is a way to write a macro to gather data on emails approved in Outlook?

I am currently sending data to interested parties, and I have voting buttons (approve/reject) on the emails.
Currently we track the approval/rejection manually. Is there a way to use a macro to track these? (all the emails go into one folder via a rule in outlook).

Or does anyone know of a way to do it in Outlook if Excel cannot?

Many thanks,
Nindi

 

[ParamRay]

The following code, run from Excel, will scan all items in Outlook and then list those with voting options or a voting response in a new worksheet. Note that it could take a minute or two to run, depending on how many emails there are.

Public Sub GetAllVotingEmails()
  Dim objOlNameSpace As Object
  Dim wksOutput As Worksheet
  Dim objOlFolder As Object
  Dim varOutput As Variant
  Dim blnNewApp As Boolean
  Dim objOlApp As Object
  Dim intCols As Integer
  Dim lngRows As Long
  
  On Error Resume Next
  Set objOlApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    On Error GoTo ErrTrap
    Set objOlApp = CreateObject("Outlook.Application")
    blnNewApp = True
  End If

  On Error GoTo ErrTrap
  Set objOlNameSpace = objOlApp.GetNamespace("MAPI")
  For Each objOlFolder In objOlNameSpace.Folders
    Call GetVotingEmails(objOlFolder, varOutput)
  Next objOlFolder
  
  If Not IsEmpty(varOutput) Then
    Set wksOutput = ThisWorkbook.Sheets.Add
    varOutput = TransposeArray(varOutput)
    lngRows = UBound(varOutput, 1)
    intCols = UBound(varOutput, 2)
    wksOutput.Range("A2").Resize(lngRows, intCols).Value = varOutput
    wksOutput.Range("A1:G1").Value = Array("Sender Name", _
                                           "Sender Email Address", _
                                           "Sent On", _
                                           "Received Time", _
                                           "Subject", _
                                           "Voting Options", _
                                           "Voting Response")
  Else
    MsgBox "No emails with voting were found.", vbInformation, "Get All Voting Emails"
  End If
  
TidyUp:
  On Error Resume Next
  If blnNewApp Then objOlApp.Quit
  Set objOlNameSpace = Nothing
  Set objOlFolder = Nothing
  Set wksOutput = Nothing
  Set objOlApp = Nothing
  Exit Sub
  
ErrTrap:
  MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical, "Get All Voting Emails"
  Resume TidyUp
End Sub

Private Sub GetVotingEmails(objOlFolder As Object, varOutput As Variant)
  Const olMail As Integer = 43
  Dim objOlSubfolder As Object
  Dim lngMailCount As Long
  Dim objOlItem As Object
  
  For Each objOlItem In objOlFolder.Items
    If objOlItem.Class = olMail Then
      If objOlItem.VotingOptions <> "" Or objOlItem.VotingResponse <> "" Then
        If IsEmpty(varOutput) Then
          lngMailCount = 1
          ReDim varOutput(1 To 7, 1 To lngMailCount)
        Else
          lngMailCount = UBound(varOutput, 2) + 1
          ReDim Preserve varOutput(1 To 7, 1 To lngMailCount)
        End If
        
        varOutput(1, lngMailCount) = objOlItem.SenderName
        varOutput(2, lngMailCount) = objOlItem.SenderEmailAddress
        varOutput(3, lngMailCount) = objOlItem.SentOn
        varOutput(4, lngMailCount) = objOlItem.ReceivedTime
        varOutput(5, lngMailCount) = objOlItem.Subject
        varOutput(6, lngMailCount) = objOlItem.VotingOptions
        varOutput(7, lngMailCount) = objOlItem.VotingResponse
      End If
    End If
  Next objOlItem
  
  For Each objOlSubfolder In objOlFolder.Folders
    Call GetVotingEmails(objOlSubfolder, varOutput)
  Next objOlSubfolder
  
  Set objOlSubfolder = Nothing
  Set objOlItem = Nothing
End Sub

Private Function TransposeArray(varItems As Variant) As Variant
  Dim varTransItems As Variant
  Dim x As Long
  Dim y As Long
  
  ReDim varTransItems(LBound(varItems, 2) To UBound(varItems, 2), _
                      LBound(varItems, 1) To UBound(varItems, 1))
  For y = LBound(varItems, 1) To UBound(varItems, 1)
    For x = LBound(varItems, 2) To UBound(varItems, 2)
      varTransItems(x, y) = varItems(y, x)
    Next x
  Next y
  
  TransposeArray = varTransItems
End Function

 

[nindisp]

Hi - thanks, but I get the following error. Do I need to specify which folder it needs to look at in Outlook?
I'm using Office 2013.

Any ideas?

---------------------------
Get All Voting Emails
---------------------------
Error 440


One or more items in the folder you synchronized do not match. To resolve the conflicts, open the items, and then try this operation again.
---------------------------
OK
---------------------------

 

[ParamRay]

Hmm.. not sure why you got the error. Were you doing things in Outlook while it was running?

You don't need to point it at a folder - it scans all folders.

Do you get the same error each time it runs?

Have you tried running it with Outlook closed and with Outlook open?

 

[nindisp]

Same error with it closed, tried re-opening it.
Does it need certain fields to be active in the Outlook window? Also wondering what this line is doing:
Const olMail As Integer = 43
If i change this, the macro runs but doesn't find any emails with voting buttons, so assuming this is setting the email type to be one with voting buttons.