Recherche de contacts dans Outlook avec code VBA

[naitgo]

Bonjour à tous,
J'ai un code qui permet d'afficher une liste déroulante des noms des contacts Outlook et qui, en sélectionnant un nom, affiche ses coordonnées dans les cellules définies dans le code.
Ce code fonctionne très bien, mais si Outlook est ouvert au moment ou l'on sélectionne un nom, Outlook se ferme avant d'afficher les coordonnées. Je travaille souvent Outlook ouvert et ce petit problème m'oblige à rouvrir Outlook très souvent.
Ce processus est-il incontournable, y a t-il un moyen d'éviter ce petit souci.
D'avance, je vous remercie pour votre aide.
Voici le code :

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
  
      If Not Target.Address = "$D$4" 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
  
    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" Then Exit Sub
  On Error GoTo Fin
  Application.EnableEvents = False
  Recherche = Range("D4")
  Set olApp = New Outlook.Application
  Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
  Set Cible = dossierContacts.Items.Find("[LastName] = '" & Recherche & "'")
  If Not Cible Is Nothing Then
    Range("G1") = Cible.CompanyName
    Range("G2") = Cible.FullName
    Range("G3") = Cible.BusinessAddressStreet
    Range("G4") = Cible.BusinessAddressPostalCode
    Range("H4") = 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

 

[Compte Supprimé 979]

Re : Recherche de contacts dans Outlook avec code VBA

Bonjour Naitgo

Je pense qu'il suffit de supprimer

olApp.Quit

à la fin de ton code

A+

 

[naitgo]

Re : Recherche de contacts dans Outlook avec code VBA

Merci BrunoM45, le petit souci était bien là !
Je n'avais pas du tout pensé à cette petite ligne.
J'ai encore beaucoup de progrès à faire en VBA !
Encore merci
A+