0

我有来自我刚刚继承的软件的自动报告。我的最终目的是让应用程序向我发送报告，然后通过宏自动提取每个报告中的重要数据，并使用该数据构建主报告。

来自报告电子邮件的源代码： [snipped]

我已经复制了上面的示例报告。我想提取某些字段的信息并将该数据自动输入到电子表格中。

我要复制的信息是以下数据：

计算机 扫描
的具有匹配文件的计算机 匹配文件
总数
关键严重性匹配
高严重性匹配
中等严重性匹配
低严重性匹配

幸运的是，这些都是整数值。现在，我的第一步是弄清楚如何：

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

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

4

1 回答 1

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

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

于 2013-09-10T12:50:43.517 回答