1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
| Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
Dim Courriel As MailItem
Dim Destinataires As Recipients
Dim Destinataire As Recipient
Dim UnContact As ContactItem
Dim Nb As Integer
Dim Ns As NameSpace
Dim Carnet As MAPIFolder
Dim V As Variant
Set Ns = GetNamespace("MAPI")
Set Carnet = Ns.GetDefaultFolder(olFolderContacts) 'Recherche dans les contacts personnels
'Set Carnet=Ns.GetDefaultFolder(olPublicFoldersAllPublicFolders.folders("Fournisseurs") 'Recherche dans les contacts partagés
Set Courriel = Item
Set Destinataires = Courriel.Recipients
'Dim myAddressList As AddressList
'Set myAddressList = Application.Session.AddressLists(1)
' ENREGISTREMENT DES CONSULTATIONS DE CHAQUE CONTACT
' Pour tous les destinataires du courriel
For Each Destinataire In Destinataires
' Rechercher dans les contacts
For Each V In Carnet.Items
If TypeName(V) = "ContactItem" Then 'Vérifier s'il s'agit d'un ContactItem
'Set UnContact = V
If UnContact.Email1Address = Destinataire.Address _
Or UnContact.Email2Address = Destinataire.Address _
Or UnContact.Email3Address = Destinataire.Address Then
' Destinataire trouvé
If UnContact.Body = "" Then
' Ajouter la première consultation dans Notes du contact
UnContact.Body = "1. " & Format(Now(), "dddddd") & " - De " & Courriel.Session.CurrentUser.Name & " - Objet : " & Courriel.Subject
UnContact.Save
Else
' Ajouter la dernière consultation à la liste dans Notes du contact
UnContact.Body = UBound(Split(V.Body, ". ")) + 1 & ". " & Format(Now(), "dddddd") & " - De " & Courriel.Session.CurrentUser.Name & " - Objet : " & Courriel.Subject & vbCrLf & UnContact.Body
UnContact.Save
End If
Exit For
End If
End If
Next V
Next Destinataire
End Sub |
Partager