Extract IP Addresses in Microsoft Outlook using macros

Question

I am trying to extract ALL IP addresses in the body of an Outlook message from the following example here.

I have tried replacing the regex from:

With Reg1
    .Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
End With

To:

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

~~But it only matches one octet.~~

Sample Text:

The IP from 192.168.10.2 needs attention.
The IP from 192.168.11.3 needs attention.
The IP from 192.168.12.4 needs attention.

Currently it only matches 168

Added extra brackets and now matches the first IP in the body of the message but not the rest.

Full code below:


Option Explicit
 Private Const xlUp As Long = -4162

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 = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
     .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]?))"
    '.Pattern = "^(([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])\.){3}([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])$"

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

0m3r 0m3r · Accepted Answer · 2017-02-15T01:40:03

^(([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])\.){3}([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])$

http://www.regextester.com/22

Regular expression to match DNS hostname or IP Address?

Extract IP Addresses in Microsoft Outlook using macros

1 Answers