Public Sub GetCurrentEmailInfo()
Dim Session As Outlook.Namespace
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim currentItem As Object
Dim currentMail As MailItem
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
'for all items do...
For Each currentItem In Selection
If currentItem.Class = olMail Then
Set currentMail = currentItem
IP_Address = GetIPAddresses(GetInetHeaders(currentMail))
MsgBox currentMail.Sender & "/" & IP_Address, vbOKOnly
End If
Next
End Sub
Private Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
' Purpose: Returns the internet headers of a message.'
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
Private Function GetIPAddresses(ByVal MsgHeader As String) As String()
Dim tempArr() As String, i As Long, RegEx As Object, RegC As Object
Set RegEx = CreateObject("vbscript.regexp")
ReDim tempArr(0)
With RegEx
.Global = True
.MultiLine = True
.Pattern = "\[?(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\]?"
End With
If RegEx.Test(MsgHeader) Then
Set RegC = RegEx.Execute(MsgHeader)
ReDim tempArr(RegC.Count - 1)
For i = 0 To RegC.Count - 1
tempArr(i) = RegC.Item(i).SubMatches(0)
Next
End If
Set RegEx = Nothing
Set RegC = Nothing
GetIPAddresses = tempArr
End Function
What do you mean by highlighted with a flag or selected, by IP address do you mean e-mail address?
Regards