使用宏從Microsoft Outlook Messsage中提取所有IP地址

Question

我一直在研究如何從Outlook郵件中提取所有 IP地址並將其複製到Excel電子表格中。我有一個工作示例，用於從OL消息中提取1個IP地址以複製到Excel單元。目前它每個單元複製1個八位字節，但理想情況下我需要1個單元中的IP地址。

另外我需要宏來檢查消息的全部正文並提取所有IP地址。消息中可能有1到100個IP地址。

樣本數據

Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis 10.1.1.10 aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum 

This IP has been flagged 192.168.1.1 
This IP has been flagged 192.168.1.2 
This IP has been flagged 192.168.1.3 
This IP has been flagged 192.168.1.4 


Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non 192.168.2.1 proident, sunt in culpa qui officia deserunt mollit anim id est laborum 

CODE

Sub CopyToExcel(olItem As Outlook.MailItem) 
Dim xlApp As Object 
Dim xlWB As Object 
Dim xlSheet As Object 
Dim vText, vText2, vText3, vText4, vText5 As Variant 
Dim sText As String 
Dim rCount As Long 
Dim bXStarted As Boolean 
Dim enviro As String 
Dim strPath As String 
Dim Reg1 As Object 
Dim M1 As Object 
Dim M As Object 

enviro = CStr(Environ("USERPROFILE")) 
'the path of the workbook 
strPath = enviro & "\Documents\test.xlsx" 
    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 the workbook to input the data 
    Set xlWB = xlApp.Workbooks.Open(strPath) 
    Set xlSheet = xlWB.Sheets("Sheet1") 

    'Find the next empty line of the worksheet 
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row 
    rCount = rCount + 1 

    sText = olItem.Body 

    Set Reg1 = CreateObject("VBScript.RegExp") 
    ' \s* = invisible spaces 
    ' \d* = match digits 
    ' \w* = match alphanumeric 

    With Reg1 
     .Pattern = "((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?))" 

    End With 
    If Reg1.Test(sText) Then 

' each "(\w*)" and the "(\d)" are assigned a vText variable 
     Set M1 = Reg1.Execute(sText) 
     For Each M In M1 
      vText = Trim(M.SubMatches(1)) 
      vText2 = Trim(M.SubMatches(2)) 
      vText3 = Trim(M.SubMatches(3)) 
      vText4 = Trim(M.SubMatches(4)) 
      ' vText5 = Trim(M.SubMatches(5)) 
     Next 
    End If 

    xlSheet.Range("B" & rCount) = vText 
    xlSheet.Range("c" & rCount) = vText2 
    xlSheet.Range("d" & rCount) = vText3 
    xlSheet.Range("e" & rCount) = vText4 
    xlSheet.Range("f" & rCount) = vText5 

    xlWB.Close 1 
    If bXStarted Then 
     xlApp.Quit 
    End If 
    Set M = Nothing 
    Set M1 = Nothing 
    Set Reg1 = Nothing 
    Set xlApp = Nothing 
    Set xlWB = Nothing 
    Set xlSheet = Nothing 
End Sub 

Answer 1

你的模式實際上完全匹配的IPv4地址，您可能會看到它在這個regex demo。這意味着，你只需要抓住整個比賽，而不是子比賽。

此外，要獲得多個事件（在regex101.com上，請參閱g修飾符），您需要設置Reg1.Global = True。

因此，使用

With Reg1 
    .Pattern = "((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?))" 
    .Global = True 
End With 

然後

For Each M In M1 
    vText = Trim(M.Value) 
Next 

的代碼的其餘部分是不是很難適應。