我从我刚刚继承的软件中获得了自动化报告。我的最终目的是让应用程序向我发送报告，然后通过宏自动提取每个报告中的重要数据，并使用该数据构建主报告。
报告电子邮件中的源代码： [剪断]
我上面复制了一份示例报告。我想提取某些字段的信息，并将该数据输入自动化到电子表格中。
我要复制的信息是：
的数据扫描的计算机
带匹配文件的计算机
总匹配文件
严重严重性匹配
高严重性匹配
中等严重程度匹配
低严重性匹配
幸运的是，这些都是整数值。现在，我的第一步是弄清楚如何：
1。）获取收到电子邮件时要运行的宏/脚本（想想我可以通过outlook规则执行此操作）
2.）删除html标签以便于数据提取
3.）有宏拉相关信息
4.）让宏以可用的格式导出相关信息（比如一个迭代列表，我可以在其中显示总和来显示结果）。
一旦我走得那么远，我想我可以自己做我想做的一切。我只是不知道如何开始。提前致谢。
编辑：它有效！
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
现在有效。我的下一步是定期获取数据，并以有意义的格式呈现数据，同时找出数据透视表。但这完全超出了这个问题的范围。感谢任何阅读它并祝你好运的人。
答案 0 :(得分：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
此代码正在输入下一个可用行。我正在研究如何在数据透视表中输入它。感谢所有阅读它的人。