Voila un script loin d'être optimisé mais qui peut vous servir de base pour un développement perso. Il consiste à récuperer les adresses des expéditeurs de mails de la boîte de reception et à les ajouter aux contacts (carnet d'adresses sous Outlook)
Voilà le code à ajouter dans un fichier texte et à renommer en *.vbs.
J'aurais pu optimiser le code en procédant en deux étapes :
- récuperer les adresses des expéditeurs des mails (chaque adresse est unique)
- inserer si besoin l'adresse dans les contacts
La ligne 'If i>10 Then Exit For permet de tester le script sur les premiers messages...
'On crée les objets utiles pour acceder aux données de Outlook
Set oOutlook = CreateObject("Outlook.Application")
Set oNS = oOutlook.GetNameSpace("MAPI")
Set oMessages = oNS.GetDefaultFolder(6) 'On récupère l'ensemble des messages
Set oTousMessages = oMessages.items
Set oContacts = oNS.GetDefaultFolder(10)'On récupère l'ensemble des contacts
Set oTousContacts = oContacts.items
messageCree = ""
messageUpdate = ""
'un premier message pour être sûr d'avoir double cliqué ;-)
MsgBox("La recherche commence... ça peut être très long")
i = 0
'on boucle sur l'ensemble des messages
For Each myItem In oTousMessages
i = i + 1
'If i>10 Then Exit For
'Gestion de l'erreur pour les confirmations de lecture qui n'acceptent pas le .reply...
On Error Resume Next
'on récupère l'expéditeur en faisant un reply
Set myReply = myItem.Reply
If err.number <> 0 Then
'exemple : confirmation de lecture
'MsgBox (err.description)
'myItem.display 'Pour afficher le message qui pose problème
Else
'Rechercher le destinataire (Pour chaque expediteur, on regarde s'il existe dans les contacts)
For Each myRecip In myReply.Recipients
'Afficher l'adresse email
blnExiste = false
FOR EACH loItem IN oTousContacts
IF LCase(loItem.Email1Address) = LCase(myRecip.Address) Then 'si l'adresse mail est la même
If myRecip.Address <> myRecip.name Then 'si le nom est différent de l'adresse mail
loItem.Save()
End If
blnExiste = true
messageUpdate = messageUpdate & myRecip.name & "(" & myRecip.Address & ")" & vbcrlf
End IF
Next
If not blnExiste Then
'il n'existe pas alors on le crée
Set loNewContact = oContacts.Items.Add()
loNewContact.Fullname = myRecip.name
loNewContact.Email1Address = myRecip.Address
loNewContact.save()
messageCree = messageCree & myRecip.name & "(" & myRecip.Address & ")" & vbcrlf
Set loNewContact = nothing
End If
Next
'Supprimer les objets
Set myReply = Nothing
End If
Next
MsgBox(i & " messages traités")
MsgBox("nouveaux contacts crées : " & vbcrlf & vbcrlf & messageCree)
MsgBox("Contacts mis à jour : " & vbcrlf & vbcrlf & messageUpdate)
