Code qui ne fonctionne plus, subitement

Bonsoir à tous,

J'utilise un code excel VBA 2007 depuis 6 ans sans souci, mais depuis quelques jours il bloque quasiment dès le départ.

Fonctionnement normal du code :

Je saisi le nom d'un contact dans une cellule, ensuite le code affiche le nom et les coordonnées du contact dans différentes cellules.

Le code va chercher les informations dans les contacts d'Outlook.

Aujourd'hui il se bloque à ce niveau :

Resultat = Resultat & Cible.LastName & ","

Next

Voici le code complet :

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 Application.Intersect(Target, Range("G30")) Is Nothing Then
    If Range("G30") = "Graphic Communication" Then
      Rows("33:49").EntireRow.Hidden = True
      Rows("50:175").EntireRow.Hidden = False
    Else
      Rows("33:49").EntireRow.Hidden = False
      Rows("50:175").EntireRow.Hidden = True
    End If
  End If

      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:

En espérant que quelqu'un veuille bien m'aider à résoudre mon problème.

D'avance je vous remercie pour votre aide.

Naitgo

Bonjour,

exécute la macro suivante une seule fois et refait un essai,

Sub Reset_Events()
Application.EnableEvents = True
End Sub

Bonjour,

Merci i20100 pour ton aide.

J'ai essayé la macro mais cela ne change rien, j'ai toujours le blocage avec la fenêtre d'erreur qui s'affiche :

"Erreur d'exécution '13'

Incompatibilité de type".

Merci d'avance pour votre aide.

Naitgo

re,

j'ai fait le test sur cette parti de code, et je n'obtient pas d'erreur,

vérifie si la référence à outlook est toujours coché

Sub test1()
Dim olApp As Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Dim Recherche As String

Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

For Each Cible In dossierContacts.Items
  Resultat = Resultat & Cible.LastName & ","
Next
End Sub

Merci pour ta réponse.

La référence à Outlook doit être cochée à quel endroit ?

Merci pour ta réponse.

La référence à Outlook doit être cochée à quel endroit ?

ici,

vba reference outlook

La référence est bien cochée.

J'ai fait fait "réparer" avec le CD Outlook, mais c'est toujours pareil.

Je suis dépité...

Bonjour à tous,

Salut Isa ...

Est-ce-que ta propre configuration d'Outlook n'aurait pas été modifiée ...?

Si ta macro plante au niveau de ...

Set dossierContacts = _
        olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

Cela vaudrait la peine que tu vérifies si to Outlook est toujours opérationnel ...surtout avec sa liste de contacts ...

En espèrant que cela t'aide

Merci pour votre aide.

Comment je peux vérifier la liste Outlook ?

C'est vrai qu'il y a quelques jours j'ai voulu envoyer des mails en nombre et cela n'a pas bien fonctionné.

J'ai fais plusieurs fois "nouvelle liste de distribution" après avoir sélectionné tout les contacts.

Sinon mon Outlook fonctionne normalement.

Re,

Malheureusement je ne connais pas du tout Outlook ...

Mais ... je crois bien que tu as trouvé l'explication ...

Outlook est capable de créér de vrais noeuds dans les listes de contact et de distribution ...

Maintenant que tu connais la source de tes ennuis ... il va falloir défaire ' les noeuds ' ... et remettre de l'odre dans Outlook ...

Bonjour à tous,

Toujours pas trouvé de solution pour débloquer mon code.

J'ai vérifié Outlook, normalement pas de problème.

J'ai mis tout ça sur un autre ordinateur et j'ai toujours le même souci.

Je me demande si cela ne peut pas venir d'une mise à jour de Windows ?

Qu'en pensez-vous ?

Autre question : serait-il possible que le code aille chercher les contacts sur Gmail ?

Encore merci pour votre aide.

re,

essai avec olFolderSuggestedContacts au lieu de olFolderContacts

Rechercher des sujets similaires à "code qui fonctionne subitement"