Avatar of Jegajothy vythilingam
Jegajothy vythilingam
Flag for United States of America asked on

Outlook 2010 - creating a macro

Is it possible to create a macro that will search in the email that is highlighted the IP address of  only the  sender.  Even if I run the macro  in the Spam or Junk folder.   Thank you.
OutlookMicrosoft Applications

Avatar of undefined
Last Comment
Jegajothy vythilingam

8/22/2022 - Mon
Rgonzo1971

Hi,

What do you mean by highlighted with a flag or selected, by IP address do you mean e-mail address?

Regards
Jegajothy vythilingam

ASKER
In response to Rgonzo1971, I mean selected. If it ll make it easier, maybe when opened, I could run the macro.    Yes I want to know the IP address of the email sender. Thank u.
Rgonzo1971

Hi,

This could help.
Since I am not on my work machine so no Outlook to verify the code

Do not forget to reference the regexp

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

Open in new window


Regards
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
Jegajothy vythilingam

ASKER
In response to Rgfonzo1971, thank u.  Can u please advice how to implement this in Outlook?
Thank u.
ASKER CERTIFIED SOLUTION
Rgonzo1971

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
Jegajothy vythilingam

ASKER
U sure got awesoime talent.