Outlook 2010 - creating a macro

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

Select all Open in new window

Make a reference to regexp in the Menu Tools / Reference

then assign a button to macro "GetCurrentEmailInfo", see first reference

Regards