Class action lawsuits come with months, if not years, of effort to collect attorney’s fees out of settlements. Increasingly lawyers find themselves in need of processing thousands of email messages to account for their time. Despite the capabilities of eDiscovery within mail systems, the reality is that us – people – tend to store email in a variety of ways.  One of our clients in Miami just had to go through something like this, and like many attorneys he was unsure what to do next. He new he needed to review a thousands of emails (as did his co-counsels), assign billing to them, and submit them. However, all that came with a risk. Surely, among the various messages there are comments, reactions, and thoughts that could be misconstrued.  For this, the emails would need to be redacted.

For anyone who has done eDiscovery work, it’s opposite of redaction. For anyone who has done redactive work, it’s usually not something one does to the entire body of all emails like this request shaped out to be.  Fortunately, the problem reached one of our solution consultants who had a simple answer: eDiscovery and an export to Excel.

During the information gathering stage we learned that the data was stored in a prepared Personal Folder Files (PSTs) and possibly in a case management software in the form of individual EML files.  After further digging we were able to translate the vision of the attorneys involved into a technical answer: a spreadsheet that contains the relevant metadata and subjects of each message. That would be sufficient to do the job.  To do this quickly we spun up an Amazon Web Services instance with plenty of horsepower and got busy putting together some code.

Now, experience has taught us that you have to be ready for the unexpected.  There was agreement that there is likely more to come out of this, so we prepared a very simple Outlook Macro to save each highlighted message as a row in an Excel document.  Ran it, tested it, and submitted it within a few hours.   At the time we had a budget of $3,500 and 1 week.  At about 2 billable hours in we had results that seemingly satisfied the attorneys. Cool.

Apparently the results impressed because the scope grew exponentially.  Turned out that the PST file we worked with was just the tip of the iceberg, and the real treasure trove of emails was in the lead attorneys mailbox.  Not organized or structured – just as a lonely search result in an open Outlook window.  Now, the trouble with this kind of thing is that Outlook searches depend on cached mode, Windows indexing, and the oomph of the machine.  With a 50Gb mailbox, a 3 month cache, and aging equipment none of that was going to work.  Queue Amazon Web Services once again along with Microsoft Office 365 eDiscovery.

Because this firm was already a managed services client we had our full array of site and cloud application security tools deployed.  This meant proper Office 365 plans, authorized access, and the means to execute.  We performed eDiscovery searches in lieu of the Outlook search being used and waited for the results.  Soon enough those arrived, and were transferred – in PST form – to our AWS EC2 instances for further processing.  There all we had to do was massage out the message corruption (and there was some when you deal with this much data) and create our spreadsheets.

The project was completed 4 days ahead of schedule and at about 30% of the original budget.  Here is the Outlook Macro thad did the bulk of the heavy lifting:

Outlook VBS Macro

Option Explicit
 Sub CopyToExcel()
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String

 Dim currentExplorer As Explorer
 Dim Selection As Selection
 Dim olItem As Outlook.MailItem
 Dim obj As Object
 Dim strColA, strColB, strColC, strColD, strColE, strColF, strColG, strColH, strColI, strColJ, strColK, strColL, strColM, strColN, strColO, strColP, strColQ, strColR, strColS, strColT, strColU, strColV, strColW, strColX, strColY, strColZ, strColAA, strColAB, strColAC, strColAD, strColAE, strColAF, strColAG, strColAH, strColAI, strColAJ, strColAK, strColAL, strColAM, strColAN, strColAO, strColAP, strColAQ As String
' Get Excel set up
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
'## Open a specific workbook to input the data
'the path of the workbook under the windows user account
'enviro = CStr(Environ("USERPROFILE"))
' strPath = enviro & "\Documents\test.xlsx"
'     Set xlWB = xlApp.Workbooks.Open(strPath)
'     Set xlSheet = xlWB.Sheets("Sheet1")
'## End Specific workbook

'## Use New Workbook
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Sheet1")
'## end use new workbook

' Add column names
  xlSheet.Range("A1") = "Sent"
  xlSheet.Range("B1") = "SentOn"
  xlSheet.Range("C1") = "Sender Name"
  ' xlSheet.Range("D1") = "Sender Address"
  xlSheet.Range("E1") = "Subject"
  xlSheet.Range("F1") = "To"
  xlSheet.Range("G1") = "Recipients"
  xlSheet.Range("H1") = "CC"
  xlSheet.Range("I1") = "BCC"
  xlSheet.Range("J1") = "Size"
  xlSheet.Range("K1") = "Attachments"
  xlSheet.Range("L1") = "Importance"
  xlSheet.Range("M1") = "Message Class"
  xlSheet.Range("N1") = "Creation Time"
  xlSheet.Range("O1") = "Received Time"
  xlSheet.Range("P1") = "Class"
  xlSheet.Range("Q1") = "Parent"
  xlSheet.Range("R1") = "Read Receipt Requested"
  xlSheet.Range("S1") = "ReceivedByEntryID"
  xlSheet.Range("T1") = "Received By Name"
  xlSheet.Range("U1") = "ReceivedOnBehalfOfEntryID"
  xlSheet.Range("V1") = "RecivedOnBehalfOfName"
  xlSheet.Range("W1") = "Billing Info"
  xlSheet.Range("X1") = "Categories"
  xlSheet.Range("Y1") = "AutoForwarded"
  xlSheet.Range("Z1") = "ConversationID"
  xlSheet.Range("AA1") = "ConversationIndex"
  xlSheet.Range("AB1") = "ConversationTopic"
  xlSheet.Range("AC1") = "DeferredDeliveryTime"
  ' xlSheet.Range("AD1") = "BodyFormat"
  ' xlSheet.Range("AE1") = "Body"
  ' xlSheet.Range("AF1") = "HTMLBody"
  xlSheet.Range("AG1") = "lastModTime"
  xlSheet.Range("AH1") = "Mileage"
  xlSheet.Range("AI1") = "OutlookInternalVersion"
  xlSheet.Range("AJ1") = "OutlookVersion"
  xlSheet.Range("AK1") = "ReplyRecipientNames"
  ' xlSheet.Range("AL1") = "RTFBody"
  xlSheet.Range("AM1") = "SenderEmailType"
  xlSheet.Range("AN1") = "SendUsingAccount"
  xlSheet.Range("AO1") = "Sensitivity"
  xlSheet.Range("AP1") = "Unread"
  xlSheet.Range("AQ1") = "UserProperties"

' Process the message record
  On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
  For Each obj In Selection

    Set olItem = obj
 'collect the fields
    strColA = olItem.Sent
    strColB = olItem.SentOn
    strColC = olItem.SenderName
    ' strColD = olItem.SenderEmailAddress
    strColE = olItem.Subject
    strColF = olItem.To
    strColG = olItem.Recipients
    strColH = olItem.CC
    strColI = olItem.BCC
    strColJ = olItem.Size
    strColK = olItem.Importance
    strColL = olItem.Attachments
    strColM = olItem.MessageClass
    strColN = olItem.CreationTime
    strColO = olItem.ReceivedTime
    strColP = olItem.Class
    strColQ = olItem.Parent
    strColR = olItem.ReadReceiptRequested
    strColS = olItem.ReceivedByEntryID
    strColT = olItem.ReceivedByName
    strColU = olItem.ReceivedOnBehalfOfEntryID
    strColV = olItem.ReceivedOnBehalfOfName
    strColW = olItem.BillingInformation
    strColX = olItem.Categories
    strColY = olItem.AutoForwarded
    strColZ = olItem.ConversationID
    strColAA = olItem.ConversationIndex
    strColAB = olItem.ConversationTopic
    strColAC = olItem.DeferredDeliveryTime
    'Body Stuff
    ' strColAD = olItem.BodyFormat
    ' strColAE = olItem.Body
    ' strColAF = olItem.HTMLBody
    strColAG = olItem.LastModificationTime
    strColAH = olItem.Mileage
    strColAI = olItem.OutlookInternalVersion
    strColAJ = olItem.OutlookVersion
    strColAK = olItem.ReplyRecipientNames
    ' strColAL = olItem.RTFBody
    ' Final Meta
    strColAM = olItem.SenderEmailType
    strColAN = olItem.SendUsingAccount
    strColAO = olItem.Sensitivity
    strColAP = olItem.UnRead
    strColAQ = olItem.UserProperties


'### Get all recipient addresses
' instead of To names
Dim strRecipients As String
Dim Recipient As Outlook.Recipient
For Each Recipient In olItem.Recipients
 strRecipients = Recipient.Address & "; " & strRecipients
 Next Recipient

  strColD = strRecipients
'### end all recipients addresses

'### Get the Exchange address
' if not using Exchange, this block can be removed
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColB)

If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
    Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' ### End Exchange section

'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("C" & rCount) = strColC
    ' xlSheet.Range("D" & rCount) = strColD
    xlSheet.Range("E" & rCount) = strColE
    xlSheet.Range("F" & rCount) = strColF
    xlSheet.Range("G" & rCount) = strColG
    xlSheet.Range("H" & rCount) = strColH
    xlSheet.Range("I" & rCount) = strColI
    xlSheet.Range("J" & rCount) = strColJ
    xlSheet.Range("K" & rCount) = strColK
    xlSheet.Range("L" & rCount) = strColL
    xlSheet.Range("M" & rCount) = strColM
    xlSheet.Range("N" & rCount) = strColN
    xlSheet.Range("O" & rCount) = strColO
    xlSheet.Range("P" & rCount) = strColP
    xlSheet.Range("Q" & rCount) = strColQ
    xlSheet.Range("R" & rCount) = strColR
    xlSheet.Range("S" & rCount) = strColS
    xlSheet.Range("T" & rCount) = strColT
    xlSheet.Range("U" & rCount) = strColU
    xlSheet.Range("V" & rCount) = strColV
    xlSheet.Range("W" & rCount) = strColW
    xlSheet.Range("X" & rCount) = strColX
    xlSheet.Range("Y" & rCount) = strColY
    xlSheet.Range("Z" & rCount) = strColZ
    xlSheet.Range("AA" & rCount) = strColAA
    xlSheet.Range("AB" & rCount) = strColAB
    xlSheet.Range("AC" & rCount) = strColAC
    ' xlSheet.Range("AD" & rCount) = strColAD
    ' xlSheet.Range("AE" & rCount) = strColAE
    ' xlSheet.Range("AF" & rCount) = strColAF
    xlSheet.Range("AG" & rCount) = strColAG
    xlSheet.Range("AH" & rCount) = strColAH
    xlSheet.Range("AI" & rCount) = strColAI
    xlSheet.Range("AJ" & rCount) = strColAJ
    xlSheet.Range("AK" & rCount) = strColAK
    ' xlSheet.Range("AL" & rCount) = strColAL
    xlSheet.Range("AM" & rCount) = strColAM
    xlSheet.Range("AN" & rCount) = strColAN
    xlSheet.Range("AO" & rCount) = strColAO
    xlSheet.Range("AP" & rCount) = strColAP
    xlSheet.Range("AQ" & rCount) = strColAQ
'Next row
  rCount = rCount + 1

' size the cells
    ' xlSheet.Columns("C:C").ColumnWidth = 100
    ' xlSheet.Columns("D:D").ColumnWidth = 30
    xlSheet.Columns("A:E").VerticalAlignment = xlTop

 xlApp.Visible = True

' to save but not close

' to save and close
'     xlWB.Close 1
'     If bXStarted Then
'         xlApp.Quit
'     End If
' end save and close
     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlSheet = Nothing
     Set xlWB = Nothing
     Set xlApp = Nothing
 End Sub