Create macro in Outlook to extract data from reports

Question

I have automated reports coming in from a software that I just inherited. My final intention is to have the application send me the reports and then have the important data in each report automatically extracted via macro and use that data to build a master report.

Source code from report email: [snipped]

I've copied a sample report above. I would like to extract the information for certain fields and automate that data entry into a spreadsheet.

The information I would like to copy is the data for:

Computers Scanned
Computers with Matched Files
Total Matched Files
Critical Severity Match
High Severity Match
Medium Severity Match
Low Severity Match

Fortunately these are all integer values. For now, my first step is figuring out how to:

1.) Get a macro/script to be run when the email is received (think I can do this through outlook rule)
2.) Remove the html tags for easier data extraction
3.) Have the macro pull the relevant information
4.) Have the macro export the relevant information in a usable format (say an iterating list where I can just take the sum to show results).

Once I get that far, I think I can do everything else I want by myself. I just don't know how to start. Thanks in advance.

Edit: it works!

Option Explicit
'Requires me to define all variables that are called in the sub

'Declaring my global variables below

Dim emailText As String
'Used to capture email text
Dim xlSheet As Object
'Set the xlSheet that you are working on
Dim olItem As Outlook.MailItem
'Setting outlook mail item

Dim xlApp As Object
'No idea what this is used for

Dim xlWB As Object
'Used to open the workbook
Dim x As Integer
'Test variable
Dim bXStarted As Boolean
'Boolean operator to tell if excel is started

Dim vText As Variant
 Dim vPara As Variant
 Dim sText As String
 Dim vItem As Variant
 Dim oRng As Range
 Dim i As Long
 Dim rCount As Long
 Dim sLink As String
 Dim tLink As String
 Dim emailTextMod As String
 Dim emailTextMod2 As String
 Dim pString As String
 Dim myNum As Integer
 Dim myNumTwo As Integer
Dim dashUpdates(7)
'Variables to be pulled, Computers scanned, computers with matched files, total matched files
'critical, high, med, low
Const filePath As String = "C:\Users\username\Documents\TestBook.xlsx"
'added path of the test data congregation point



Sub extractText()
'Sub procedure to take information from email for dashboard
'    MsgBox "Doing something!"
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
'Handles error if no message
    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
    x = 1
    Set xlWB = xlApp.Workbooks.Open(filePath)
    Set xlSheet = xlWB.Sheets("TestSheet")
    'Process records
For Each olItem In Application.ActiveExplorer.Selection
    emailText = olItem.Body

'==================================
'===       Extract data         ===
'==================================

rCount = xlSheet.UsedRange.Rows.Count
'MsgBox ("rCount is " & rCount)
rCount = rCount + 1


'===============================================
'=== grab item 1 (computers scanned)         ===
'===============================================

sLink = "Computers Scanned"
myNum = InStrRev(emailText, sLink)
'MsgBox ("myNum is " & myNum)
tLink = "Computers with Failed Scan"
myNumTwo = InStr(emailText, tLink)
'MsgBox ("myNumTwo is " & myNumTwo)
x = myNumTwo - myNum
'MsgBox ("x is " & x)
pString = Mid(emailText, myNum, x)
'MsgBox pString
pString = Replace(pString, "Computers Scanned", "")
pString = Trim(pString)
'MsgBox ("pString is " & pString)
    xlSheet.Range("A" & rCount).Value = pString

'==================================
'===       grab item 2  (fail scan)        ===
'==================================

sLink = "Computers with Failed Scan"
myNum = InStrRev(emailText, sLink)
'MsgBox ("myNum is " & myNum)
tLink = "Computers with Matched Files"
myNumTwo = InStr(emailText, tLink)
'MsgBox ("myNumTwo is " & myNumTwo)
x = myNumTwo - myNum
'MsgBox ("x is " & x)
pString = Mid(emailText, myNum, x)
'MsgBox pString
pString = Replace(pString, sLink, "")
pString = Trim(pString)
'MsgBox ("pString is " & pString)
    xlSheet.Range("B" & rCount).Value = pString



'==================================
'===       grab item 3 (cpu match)         ===
'==================================

sLink = "Computers with Matched Files"
myNum = InStr(emailText, sLink)
myNum = myNum + 28
'MsgBox ("myNum is " & myNum)
tLink = "%"
myNumTwo = InStr(emailText, tLink)
'MsgBox ("myNumTwo is " & myNumTwo)
x = myNumTwo - myNum
'MsgBox ("x is " & x)
pString = Mid(emailText, myNum, x)
'MsgBox pString
pString = Replace(pString, sLink, "")
pString = Trim(pString)
'MsgBox ("pString is " & pString)
    xlSheet.Range("C" & rCount).Value = pString

'==================================
'===       grab item 4 (crit)         ===
'==================================

sLink = "Critical Severity Match"
myNum = InStrRev(emailText, sLink)
'MsgBox ("myNum is " & myNum)
tLink = "High Severity Match"
myNumTwo = InStr(emailText, tLink)
'MsgBox ("myNumTwo is " & myNumTwo)
x = myNumTwo - myNum
'MsgBox ("x is " & x)
pString = Mid(emailText, myNum, x)
'MsgBox pString
pString = Replace(pString, sLink, "")
pString = Trim(pString)
'MsgBox ("pString is " & pString)
    xlSheet.Range("D" & rCount).Value = pString

'==================================
'===       grab item 5          ===
'==================================

sLink = "High Severity Match"
myNum = InStrRev(emailText, sLink)
'MsgBox ("myNum is " & myNum)
tLink = "Medium Severity Match"
myNumTwo = InStr(emailText, tLink)
'MsgBox ("myNumTwo is " & myNumTwo)
x = myNumTwo - myNum
'MsgBox ("x is " & x)
pString = Mid(emailText, myNum, x)
'MsgBox pString
pString = Replace(pString, sLink, "")
pString = Trim(pString)
'MsgBox ("pString is " & pString)
    xlSheet.Range("E" & rCount).Value = pString

'==================================
'===       grab item 6          ===
'==================================

sLink = "Medium Severity Match"
myNum = InStrRev(emailText, sLink)
'MsgBox ("myNum is " & myNum)
tLink = "Low Severity Match"
myNumTwo = InStr(emailText, tLink)
'MsgBox ("myNumTwo is " & myNumTwo)
x = myNumTwo - myNum
'MsgBox ("x is " & x)
pString = Mid(emailText, myNum, x)
'MsgBox pString
pString = Replace(pString, sLink, "")
pString = Trim(pString)
'MsgBox ("pString is " & pString)
    xlSheet.Range("F" & rCount).Value = pString

'==================================
'===       grab item 7          ===
'==================================

sLink = "Low Severity Match"
myNum = InStrRev(emailText, sLink)
'MsgBox ("myNum is " & myNum)
tLink = "Matched Files by Policies"
myNumTwo = InStr(emailText, tLink)
'MsgBox ("myNumTwo is " & myNumTwo)
x = myNumTwo - myNum
'MsgBox ("x is " & x)
pString = Mid(emailText, myNum, x)
'MsgBox pString
pString = Replace(pString, sLink, "")
pString = Trim(pString)
'MsgBox ("pString is " & pString)
    xlSheet.Range("G" & rCount).Value = pString

'====================================
'===     Acknowledgement          ===
'====================================

MsgBox ("DLP Report Spreadsheet Updated")




'   Example paste to excel
'    xlSheet.Range("C2").Value = emailTextMod2

'Replace( string(stringname), searchtext, replacetext )
'Data post to excel

'
'    ActiveCell.FormulaR1C1 = "Enter information"
'    Range("A2").Select
'vPara = Split(emailText, Chr(13))
'Find the next empty line of the worksheet
'    For i = 0 To UBound(vPara)
'         If InStr(1, vPara(i), "Subject:") > 0 Then
'             rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
'             rCount = rCount + 1
'             vText = Split(vPara(i), Chr(58))
'             vItem = Split(vText(2) & vText(3), ChrW(34))
'             xlSheet.Range("A" & rCount) = Trim(Replace(vText(1), "Solicitation Number", ""))
'             xlSheet.Range("B" & rCount) = Trim(vItem(1))
'             xlSheet.Range("C" & rCount) = Trim(Replace(vText(4), "Office", ""))
'             xlSheet.Range("D" & rCount) = Trim(Replace(vText(5), "Location", ""))
'             xlSheet.Range("E" & rCount) = Trim(Replace(vText(6), "Notice Type", ""))
'             xlSheet.Range("F" & rCount) = Trim(Replace(vText(7), "Posted Date", ""))
'             xlSheet.Range("G" & rCount) = Trim(Replace(vText(8), "Response Date", ""))
'             xlSheet.Range("H" & rCount) = Trim(Replace(vText(9), "Set Aside", ""))
'             xlSheet.Range("I" & rCount) = Trim(vText(10))
'         End If
'     Next i
 xlWB.Save
 Next olItem
 xlWB.Close SaveChanges:=True
 If bXStarted Then
     xlApp.Quit
 End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
'    Set emailTextMod = Nothing

End Sub

Function myfunction(a, b)
myfunction = a + b
End Function


'    Range("A1").Select
'    Selection.Copy
'    Sheets("Sheet2").Select
'    ActiveSheet.Paste

It works now. My next step is getting that data to come in regularly and to present it in a meaningful format along with figuring out pivot tables. That is all outside the scope of this question though. Thanks to anyone that read it and good luck.

Answer 1

Option Explicit
'Requires me to define all variables that are called in the sub

'Declaring my global variables below

Dim emailText As String
'Used to capture email text
Dim xlSheet As Object
'Set the xlSheet that you are working on
Dim olItem As Outlook.MailItem
'Setting outlook mail item

Dim xlApp As Object
'No idea what this is used for
Dim xlWB As Object
'Used to open the workbook
Dim dbApp As Object
'No idea what this is used for
Dim dbTable As Object
'Used to open the workbook

Dim bXStarted As Boolean
'Boolean operator to tell if excel is started
Dim cXStarted As Boolean
'Boolean operator to tell if access is started

 Dim vText As Variant
 Dim vPara As Variant
 Dim sText As String
 Dim vItem As Variant
 Dim oRng As Range
 Dim i As Long, rCount As Long, sCount As Long
 Dim sLink As String, tLink As String, emailTextMod As String, emailTextMod2 As String, pString As String
 Dim myNum As Integer, myNumTwo As Integer, x As Integer

 Dim dashUpdates(7)
'Variables to be pulled, Computers scanned, computers with matched files, total matched files
'critical, high, med, low
Const filePath As String = "C:\Users\SNIPPED\Documents\TestBook.xlsx"
Const filePathTwo As String = "C:\Users\SNIPPED\Documents\SNIPPED.accdb"

'https://SNIPPED cuments   <- dashboard path
'added path of the test data congregation point

'============================================
'===  Open Excel and select sheet         ===
'============================================

Sub extractText()
'Sub procedure to take information from email for dashboard
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
    'Handles error if no message
    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
    x = 1
    Set xlWB = xlApp.Workbooks.Open(filePath)
    Set xlSheet = xlWB.Sheets("TestSheet")
    'Process records
For Each olItem In Application.ActiveExplorer.Selection
    emailText = olItem.Body

'============================================
'===  Open Access and select sheet        ===
'============================================

'    Set dbApp = GetObject(, "Access.Application")
'    If Err <> 0 Then
'     Application.StatusBar = "Please wait while Access source is opened ... "
'     Set dbApp = CreateObject("Access.Application")
'     cXStarted = True
'    End If






'    x = 1
'    Set dbTable = dbApp.Workbooks.Open(filePath)
'    Set xlSheet = xlWB.Sheets("TestSheet")
'    'Process records
'For Each olItem In Application.ActiveExplorer.Selection
'    emailText = olItem.Body


'Sub extractText()
'Sub procedure to take information from email for dashboard
'    If Application.ActiveExplorer.Selection.Count = 0 Then
'        MsgBox "No Items selected!", vbCritical, "Error"
'        Exit Sub
'    End If
'Handles error if no message
'    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
'    x = 1
'    Set xlWB = xlApp.Workbooks.Open(filePath)
'    Set xlSheet = xlWB.Sheets("TestSheet")
    'Process records
'For Each olItem In Application.ActiveExplorer.Selection
'    emailText = olItem.Body

'==================================
'===       Extract data         ===
'==================================

rCount = xlSheet.UsedRange.Rows.Count
'Finds last used row
rCount = rCount + 1
'Adds one to last used row to get to unused row

'===============================================
'=== Count scans (completed)                 ===
'===============================================

'sLink = "Scan on "
'sCount = 0
'myNum = 0
'Do Until myNum >= Len(emailText)
'
 '       emailText = Mid(LCase(emailText), myNum + 1, (Len(emailText) - myNum))
'
   '     myNumTwo = InStr(emailText, sLink)
  '      If myNumTwo > 0 Then
'
 '           sCount = sCount + 1
  '          myNum = (myNumTwo + Len(sLink) - 1) + 1
'               ^ supposed to approximate       " intCursor += (intPlaceOfPhrase + Len(phrase) - 1)"

 '       Else

'            myNum = Len(emailText)

'        End If

'    Loop
'MsgBox ("sCount is " & sCount)

'===============================================
'=== grab item (date and time    )           ===
'===============================================

'sLink = "Scan on "
'myNum = InStr(emailText, sLink)



'===============================================
'=== grab item (scan group       )           ===
'===============================================

'sLink = "Scan on "
'myNum = InStrRev(emailText, sLink)
'sCount = 0
'If emailText.ToLower.Contains(sLink) = True Then
'    sCount = FunctionForNumbersOfMatches
'End If

'===============================================
'=== grab item 1 (computers scanned)         ===
'===============================================

sLink = "Computers Scanned"
myNum = InStrRev(emailText, sLink)
tLink = "Computers with Failed Scan"
myNumTwo = InStr(emailText, tLink)
x = myNumTwo - myNum
pString = Mid(emailText, myNum, x)
pString = Replace(pString, "Computers Scanned", "")
pString = Trim(pString)
xlSheet.Range("C" & rCount).Value = pString

'==================================
'===       grab item 2  (fail scan)        ===
'==================================

sLink = "Computers with Failed Scan"
myNum = InStrRev(emailText, sLink)
tLink = "Computers with Matched Files"
myNumTwo = InStr(emailText, tLink)
x = myNumTwo - myNum
pString = Mid(emailText, myNum, x)
pString = Replace(pString, sLink, "")
pString = Trim(pString)
xlSheet.Range("D" & rCount).Value = pString



'==================================
'===       grab item 3 (cpu match)         ===
'==================================

sLink = "Computers with Matched Files"
myNum = InStr(emailText, sLink)
myNum = myNum + 28
tLink = "%"
myNumTwo = InStr(emailText, tLink)
x = myNumTwo - myNum
pString = Mid(emailText, myNum, x)
pString = Replace(pString, sLink, "")
pString = Trim(pString)
xlSheet.Range("E" & rCount).Value = pString

'==================================
'===       grab item 4 (crit)         ===
'==================================

sLink = "Critical Severity Match"
myNum = InStrRev(emailText, sLink)
tLink = "High Severity Match"
myNumTwo = InStr(emailText, tLink)
x = myNumTwo - myNum
pString = Mid(emailText, myNum, x)
pString = Replace(pString, sLink, "")
pString = Trim(pString)
xlSheet.Range("F" & rCount).Value = pString

'==================================
'===       grab item 5          ===
'==================================

sLink = "High Severity Match"
myNum = InStrRev(emailText, sLink)
tLink = "Medium Severity Match"
myNumTwo = InStr(emailText, tLink)
x = myNumTwo - myNum
pString = Mid(emailText, myNum, x)
pString = Replace(pString, sLink, "")
pString = Trim(pString)
xlSheet.Range("G" & rCount).Value = pString

'==================================
'===       grab item 6          ===
'==================================

sLink = "Medium Severity Match"
myNum = InStrRev(emailText, sLink)
tLink = "Low Severity Match"
myNumTwo = InStr(emailText, tLink)
x = myNumTwo - myNum
pString = Mid(emailText, myNum, x)
pString = Replace(pString, sLink, "")
pString = Trim(pString)
xlSheet.Range("H" & rCount).Value = pString

'==================================
'===       grab item 7          ===
'==================================

sLink = "Low Severity Match"
myNum = InStrRev(emailText, sLink)
tLink = "Matched Files by Policies"
myNumTwo = InStr(emailText, tLink)
x = myNumTwo - myNum
pString = Mid(emailText, myNum, x)
pString = Replace(pString, sLink, "")
pString = Trim(pString)
xlSheet.Range("I" & rCount).Value = pString

'====================================
'===     Acknowledgement          ===
'====================================

MsgBox ("Report Spreadsheet Updated")


'====================================
'===     Tidy up (save, close)    ===
'====================================


 xlWB.Save
 Next olItem
 xlWB.Close SaveChanges:=True
 If bXStarted Then
     xlApp.Quit
 End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
'    Set emailTextMod = Nothing

End Sub

Function myfunction(a, b)
myfunction = a + b
End Function


'====================================
'========     Notes          ========
'====================================

'    Range("A1").Select
'    Selection.Copy
'    Sheets("Sheet2").Select
'    ActiveSheet.Paste

This code is inputting in the next available row. I'm working on how to enter it in a pivot table now. Thanks all who read it.