Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olkLink As Outlook.Link, olkCon As Outlook.ContactItem
If Item.Class = olMail Then
'On the next line change the full name of the contact to link to'
Set olkCon = Session.GetDefaultFolder(olFolderContacts).Items.Find("[FullName] = 'John Doe'")
If TypeName(olkCon) <> "Nothing" Then Set olkLink = Item.Links.Add(olkCon)
Item.Save
End If
End Sub
Sub SetMessageContact()
Dim olkMsg As Object, olkLink As Outlook.Link, olkCon As Outlook.ContactItem
'On the next line change the full name of the contact to link to'
Set olkCon = Session.GetDefaultFolder(olFolderContacts).Items.Find("[FullName] = 'John Doe'")
For Each olkMsg in Application.ActiveExplorer.Selection
If olkMsg.Class = olMail Then
If TypeName(olkCon) <> "Nothing" Then Set olkLink = olkMsg.Links.Add(olkCon)
Item.Save
End If
Next
Set olkMsg = Nothing
Set olkLink = Nothing
Set olkCon = Nothing
End Sub
The Contacts property is intended to be a link to a contact item. What is that you want to put in the field and will it be the same string for every message? If not, then how should the script determine what to enter in the field?