K
krugi
Guest
Hello,
if you receive an email from someone whose contact details you have saved, Outlook does not link the email to the contact details. That's why it is e.g. not able to show first and last name or company name in the inbox.
The following VBA functions search the sender's email address in the contacts folder and add user-defined fields to the email in which the contact details are written. This is triggered automatically as soon as an email is added to the standard inbox. After the first email has been processed by the macro, you can then make the new fields in the folder visible by adjusting the folder view.
Private WithEvents m_Inbox As Outlook.Items
Private m_Contacts As Outlook.Items
Friend Sub Application_Startup()
Set m_Inbox = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub m_Inbox_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Set m_Contacts = Application.Session.GetDefaultFolder(olFolderContacts).Items
UpdateEmail Item
End If
End Sub
Private Sub UpdateEmail(Mail As Outlook.MailItem)
Dim Contact As Outlook.ContactItem
Dim Props As Outlook.UserProperties
Dim Prop As Outlook.UserProperty
Dim Name As String
Set Contact = GetContact(Mail.SenderEmailAddress)
If Not Contact Is Nothing Then
Set Props = Mail.UserProperties
Set Prop = GetUserProperty(Props, "AbsenderName")
Prop.Value = Contact.Fullname
Set Prop = GetUserProperty(Props, "AbsenderFirma")
Prop.Value = Contact.CompanyName
Mail.Save
End If
End Sub
Private Function GetUserProperty(Props As Outlook.UserProperties, Name As String) As Outlook.UserProperty
Dim Prop As Outlook.UserProperty
Set Prop = Props.Find(Name)
If Prop Is Nothing Then
Set Prop = Props.Add(Name, olText, True)
End If
Set GetUserProperty = Prop
End Function
Private Function GetContact(Adr As String) As Outlook.ContactItem
Dim Contact As Outlook.ContactItem
Set Contact = m_Contacts.Find("[Email1Address]='" & Adr & "'")
If Contact Is Nothing Then
Set Contact = m_Contacts.Find("[Email2Address]='" & Adr & "'")
End If
If Contact Is Nothing Then
Set Contact = m_Contacts.Find("[Email3Address]='" & Adr & "'")
End If
Set GetContact = Contact
End Function
And here is another function that you can manually, e.g. can be called via F8. This updates all emails in the current folder; it doesn't have to be the inbox. This is e.g. useful if the contact details have changed and you want to update all emails.
Public Sub UpdateAllEmails()
Dim Item As Object
Dim Folder As Outlook.MAPIFolder
Set Folder = Application.ActiveExplorer.CurrentFolder
If Folder.DefaultItemType = olContactItem Then
MsgBox "Select a folder who has no contacts"
Exit Sub
End If
Set m_Inbox = Folder.Items
Set m_Contacts = Application.Session.GetDefaultFolder(olFolderContacts).Items
For Each Item In m_Inbox
If TypeOf Item Is Outlook.MailItem Then
UpdateEmail Item
End If
Next
MsgBox "Update finished"
End Sub
Continue reading...
if you receive an email from someone whose contact details you have saved, Outlook does not link the email to the contact details. That's why it is e.g. not able to show first and last name or company name in the inbox.
The following VBA functions search the sender's email address in the contacts folder and add user-defined fields to the email in which the contact details are written. This is triggered automatically as soon as an email is added to the standard inbox. After the first email has been processed by the macro, you can then make the new fields in the folder visible by adjusting the folder view.
Private WithEvents m_Inbox As Outlook.Items
Private m_Contacts As Outlook.Items
Friend Sub Application_Startup()
Set m_Inbox = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub m_Inbox_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Set m_Contacts = Application.Session.GetDefaultFolder(olFolderContacts).Items
UpdateEmail Item
End If
End Sub
Private Sub UpdateEmail(Mail As Outlook.MailItem)
Dim Contact As Outlook.ContactItem
Dim Props As Outlook.UserProperties
Dim Prop As Outlook.UserProperty
Dim Name As String
Set Contact = GetContact(Mail.SenderEmailAddress)
If Not Contact Is Nothing Then
Set Props = Mail.UserProperties
Set Prop = GetUserProperty(Props, "AbsenderName")
Prop.Value = Contact.Fullname
Set Prop = GetUserProperty(Props, "AbsenderFirma")
Prop.Value = Contact.CompanyName
Mail.Save
End If
End Sub
Private Function GetUserProperty(Props As Outlook.UserProperties, Name As String) As Outlook.UserProperty
Dim Prop As Outlook.UserProperty
Set Prop = Props.Find(Name)
If Prop Is Nothing Then
Set Prop = Props.Add(Name, olText, True)
End If
Set GetUserProperty = Prop
End Function
Private Function GetContact(Adr As String) As Outlook.ContactItem
Dim Contact As Outlook.ContactItem
Set Contact = m_Contacts.Find("[Email1Address]='" & Adr & "'")
If Contact Is Nothing Then
Set Contact = m_Contacts.Find("[Email2Address]='" & Adr & "'")
End If
If Contact Is Nothing Then
Set Contact = m_Contacts.Find("[Email3Address]='" & Adr & "'")
End If
Set GetContact = Contact
End Function
And here is another function that you can manually, e.g. can be called via F8. This updates all emails in the current folder; it doesn't have to be the inbox. This is e.g. useful if the contact details have changed and you want to update all emails.
Public Sub UpdateAllEmails()
Dim Item As Object
Dim Folder As Outlook.MAPIFolder
Set Folder = Application.ActiveExplorer.CurrentFolder
If Folder.DefaultItemType = olContactItem Then
MsgBox "Select a folder who has no contacts"
Exit Sub
End If
Set m_Inbox = Folder.Items
Set m_Contacts = Application.Session.GetDefaultFolder(olFolderContacts).Items
For Each Item In m_Inbox
If TypeOf Item Is Outlook.MailItem Then
UpdateEmail Item
End If
Next
MsgBox "Update finished"
End Sub
Continue reading...