vba 在 Outlook 中创建宏以从报告中提取数据

Create macro in Outlook to extract data from reports

提问by Negativ

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]

来自报告电子邮件的源代码：[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).

1.) 在收到电子邮件时获取要运行的宏/脚本（认为我可以通过 Outlook 规则执行此操作）
2.) 删除 html 标签以便于数据提取
3.) 让宏提取相关信息
4.)让宏以可用格式导出相关信息（比如一个迭代列表，我可以在其中取总和来显示结果）。

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.

它现在有效。我的下一步是定期获取这些数据，并以有意义的格式呈现它，同时找出数据透视表。不过，这完全超出了这个问题的范围。感谢任何阅读它的人，祝你好运。

回答by Negativ

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.

此代码正在下一个可用行中输入。我现在正在研究如何在数据透视表中输入它。感谢所有阅读它的人。