Help with getting contact information into a user defined field in Outlook inbox

[Ggggg]

Hi,

This is my first post so apologies if it is in the wrong place / is not well explained.

I am attempting (with little to no VBA knowledge) to create a new user defined field (i.e. a column in the outlook inbox) which will display certain information about the contact(s) that the email is from.

At the moment it would be useful simply to show the contact group to which the sender of the email belongs.

A quick search on google led me to three scrips that may or may not be useful for my project.

(1) A script about creating a user defined field which shows the name of any attachments:

Sub AttachmentToUDF()

Dim i As Long
Dim myCollection As Object
Dim Msg As Outlook.MailItem
Dim objProperty As Outlook.UserProperty
Dim UserDefinedFieldName As String
Dim AttachmentString As String
AttachmentString = ""

Set myCollection = Outlook.Application.ActiveExplorer.Selection

UserDefinedFieldName = "Attachment Name"

If Not myCollection Is Nothing Then
For i = 1 To myCollection.Count
Set Msg = myCollection.Item(i)
If Msg.Attachments.Count > 0 Then
'Add final string to UDF
Set objProperty = Msg.UserProperties.Add(UserDefinedFieldName, Outlook.OlUserPropertyType.olText)
'User your function to set the property value
objProperty.Value = AttachmentNames(Msg)
Msg.Save
End If
Next i
End If

End Sub





(2) A script about finding distribution lists a contact belongs to

Sub ListNames()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder 'use Outlook.MAPIFolder if Outlook.folder fails.
Dim myDistList As Outlook.DistListItem
Dim myFolderItems As Outlook.Items
Dim myListMember As String
Dim sList As String
Dim x As Integer
Dim y As Integer
Dim iCount As Integer

myListMember = InputBox("Enter name of list member to be found")
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myFolderItems = myFolder.Items
iCount = myFolderItems.Count
sList = ""
For x = 1 To iCount
If TypeName(myFolderItems.Item(x)) = "DistListItem" Then
Set myDistList = myFolderItems.Item(x)
For y = 1 To myDistList.MemberCount
If InStr(1, myDistList.GetMember(y).Name, myListMember) Then
'MsgBox myDistList.GetMember(y).Name & vbInformation, "Distribution List"
If sList = "" Then
sList = sList & myDistList.GetMember(y).Name & vbTab & myDistList.DLName
Else
sList = sList & vbCr & myDistList.GetMember(y).Name & vbTab & myDistList.DLName
End If
End If
Next y
End If
Next x

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
End If

Set wdDoc = wdApp.Documents.Add
wdApp.Visible = True
wdApp.Activate
With wdDoc.Range
.InsertAfter sList
.ParagraphFormat.TabStops.ClearAll
.ParagraphFormat.TabStops.Add Position:=InchesToPoints(4), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
End With

Set wdDoc = Nothing
Set wdApp = Nothing
End Sub




(3) A script on triggering a macro to run each time a new email is received

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)

On Error Goto ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
' do something here
' ******************
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub



Any help with this would be much appreciated,

Oh and I'm using Outlook 2010.

Many thanks,

George