Outlook 2010 - creating a macro

Jegajothy vythilingam
Jegajothy vythilingam used Ask the Experts™
on
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.
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
Rgonzo1971
Top Expert 2016

Commented:
Hi,

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

Regards
Jegajothy vythilingamretired

Author

Commented:
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
Top Expert 2016

Commented:
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
Success in ‘20 With a Profitable Pricing Strategy

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Find out now!
Jegajothy vythilingamretired

Author

Commented:
In response to Rgfonzo1971, thank u.  Can u please advice how to implement this in Outlook?
Thank u.
Top Expert 2016
Commented:
Hi,

Please refer to http://msdn.microsoft.com/library/office/ee814736(v=office.14).aspx#odc_Office14_ta_AddingVBAProgrammingToYourOutlook2010Toolkit_VBAProgrammingInOutlook2010

Insert a module. Place the code inside (small correction) 
Public Sub GetCurrentEmailInfo()
    Dim Session As Outlook.Namespace
    Dim currentExplorer As Explorer
    Dim mySelection As Outlook.Selection
    Dim currentItem As Object
    Dim currentMail As MailItem
   
    Set currentExplorer = Application.ActiveExplorer
    Set mySelection = currentExplorer.mySelection
    
    'for all items do...
    For Each currentItem In mySelection
        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


Make a reference to regexp in the Menu Tools / Reference
regexp
then assign a button to macro "GetCurrentEmailInfo", see first reference

Regards
Jegajothy vythilingamretired

Author

Commented:
U sure got awesoime talent.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial