Private Sub Worksheet_Change(ByVal Target As Range)
Dim olApp As Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Dim Recherche As String
Dim Pwd as string
'******************** Mot de passe à adapter : ***********
Pwd = "MDP"
'******************** Déprotection de la feuille ***********
Private Sub Worksheet_Change(ByVal Target As Range)
Dim olApp As Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Dim Recherche As String
Dim Pwd As String
'******************** Mot de passe à adapter : ***********
Pwd = "MDP"
'******************** Déprotection de la feuille ***********
ActiveSheet.Unprotect Pwd
'****************************************************
If (Not Target.Address = "$D$4") And (Not Target.Address = "$D$5") Then Exit Sub
Set olApp = New Outlook.Application
Set dossierContacts = _
olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Dim s, i#, txt$
For Each Cible In dossierContacts.Items
Resultat = Resultat & Cible.LastName & ","
Next
s = Split(Resultat, ",")
1 For i = 1 To UBound(s)
txt = s(i)
If LCase(txt) < LCase(s(i - 1)) Then 'tri croissant
s(i) = s(i - 1)
s(i - 1) = txt
GoTo 1
End If
Next
Resultat = Join(s, ",")
Range("D4").Validation.Delete
Range("D4").Validation.Add xlValidateList, Formula1:=Resultat
'************************* Ajout de la 2ème condition en D5
For Each Cible In dossierContacts.Items
Resultat = Resultat & Cible.CompanyName & ","
Next
s = Split(Resultat, ",")
2 For i = 1 To UBound(s)
txt = s(i)
If LCase(txt) < LCase(s(i - 1)) Then 'tri croissant
s(i) = s(i - 1)
s(i - 1) = txt
GoTo 2
End If
Next
Resultat = Join(s, ",")
Range("D5").Validation.Delete
Range("D5").Validation.Add xlValidateList, Formula1:=Resultat
Set Cible = Nothing
Set dossierContacts = Nothing
'olApp.Quit
Set olApp = Nothing
' Si le changement du nom en D4 ne c'est pas fait, on sort
If Not Target.Address = "$D$4" And Not Target.Address = "$D$5" Then Exit Sub
On Error GoTo Fin
Application.EnableEvents = False
Recherche = Target
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Set Cible = dossierContacts.Items.Find("[" & IIf(Target.Row = 4, "LastName", "CompanyName") & "] = '" & Recherche & "'")
If Not Cible Is Nothing Then
Range("G1") = IIf(Target.Row = 4, Cible.CompanyName, Cible.LastName)
Range("G2") = Cible.FullName
Range("G3") = Cible.BusinessAddressStreet
'****************************************************************************
Range("G4") = Cible.BusinessAddressPostalCode & " " & Cible.BusinessAddressCity
Range("G5") = Cible.BusinessTelephoneNumber
Sheets("Lettre").Range("F12") = Cible.Email1Address
Else
MsgBox "Aucun contact trouvé avec le nom : " & Recherche, vbInformation, "OUPS ..."
End If
Fin:
Application.EnableEvents = True
Set Cible = Nothing
Set dossierContacts = Nothing
olApp.Quit
Set olApp = Nothing
End Sub
