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
CopyTextInClipart Contact.Department
Mail.Save
End
If
End
Sub
Sub
CopyTextInClipart(strTMP
As
String
)
Dim
objClip
As
Object
Set
objClip = CreateObject(
"New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"
)
objClip.SetText strTMP
objClip.PutInClipboard
End
Sub