Tester si contact est present dans outlook depuis excel

Version imprimable

Bonjour au forum,

Je souhaite tester depuis mon userform en cliquant sur bouton valider

- si le client est existant dans la liste des contacts outlook, il m'affiche un message
- si non il affiche un autre message et créer le nouveau contact dans outlook.
Voici le code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 Sub controleLastName_contactsOutlook() Dim olApp As New Outlook.Application Dim Cible As Outlook.ContactItem Dim dossierContacts As Outlook.MAPIFolder Dim leNom As String Dim leTel As String leNom = nom.Value leTel = TextBox2.Value Set olApp = New Outlook.Application Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts) Set Cible = dossierContacts.Items.Find("?[FullName] = '" & leNom & "'" And [HomeTelephoneNumber] = "'" & leTel & "'") If Not Cible Is Nothing Then MsgBox "Le contact existe déjà dans Ms Outlook" Else MsgBox "Le contact n'existe pas et donc va être ajouter" ajouterContactOutlook End If End Sub
Ne fonctionne pas, affichage du message d'erreur 13' incompatibilité de type" et souligne en jaune

Code:

Set Cible = dossierContacts.Items.Find("?[FullName] = '" & leNom & "'" And [HomeTelephoneNumber] = "'" & leTel & "'")

Pouvez-vous m'aider ?

Merci

Stephanie

Bonsoir,

Pour ne pas avoir de problème dans la mise en forme de la propriété FullName, je conseil de séparer Nom et Prénom.
Attention également à la mise en forme du numéro de téléphone.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub controleLastName_contactsOutlook()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim leNom As String
    Dim lePrenom As String
    Dim leTel As String
 
    leNom = nom.Value
    'A FAIRE : lePrenom  = prenom.value
    leTel = TextBox2.Value
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    Set Cible = dossierContacts.Items.Find("[LastName] = '" & leNom & "' and [FirstName] = '" & lePrenom & "'")
    If Not Cible Is Nothing Then
        If Cible.HomeTelephoneNumber = leTel Then
            MsgBox "Le contact existe déjà dans Ms Outlook"
        End If
    Else
            MsgBox "Le contact n'existe pas et donc va être ajouter"
    End If
End Sub

10/04/2012, 10h33
stephadm

Bonjour BlueMonkey et au forum

Je nom et le prenom se trouve dans la meme textbox (le pourquoi du "FullName") , et je préfère tel quel car je suis obligé de tout refaire le programme.

Peux-t-on faire le control uniquement sur le nom et le téléphone ?

Concernant le format du téléphone, j'utilise ceci : 00.00.00.00.00

Merci

Stéphanie
10/04/2012, 12h24
BlueMonkey

Bonjour,

Citation:

Je nom et le prenom se trouve dans la meme textbox (le pourquoi du "FullName") , et je préfère tel quel car je suis obligé de tout refaire le programme.

Comme indiqué l'utilisation de la clé FullName me semble risqué, parce que la mise en forme est assez particulière.
(faire un test de recherche manuel avec Prénom et nom, puis utiliser le débugger sur Cible pour se faire une idée de la mise en forme).

Ensuite la ligne 16 du code précédent pourra être remplacé par :
Set Cible = dossierContacts.Items.Find("[FullName] = '" & leNom & "'").

bonjour BlueMonkey, et au forum

Désolé de ne pas avoir repondu avant j'étais sur mon autre projet.

Maintenant tout va jusqu'à la fin sauf que, la macro m'annonce toujours que "Le contact n'existe pas". Dans le code j'ai ciblé directment sur l'email pour vérifier avec

Code:

Set Cible = dossierContacts.Items.Find("[Email1Address] = '" & leMail & "'")

Comment faire, j'ai l'impression que ça ne fonctionne pas, j'ai le même problème avec les RDV.

Pour info
Code:

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 Sub RDVOutlookExistant() Dim OutlApp As New Outlook.Application Dim OutlMapi As Outlook.Namespace Dim OutlFolder As Outlook.MAPIFolder Dim OutlAppointment As Outlook.AppointmentItem Dim OutlItems As Outlook.Items Dim DateDebut As String DateDebut = TextBox1.Value & " " & TextBox4.Value Set OutlMapi = OutlApp.GetNamespace("MAPI") Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar) Set OutlItems = OutlFolder.Items On Error Resume Next Set OutlAppointment = OutlItems.Find("[Start] = '" & DateDebut & "'") On Error GoTo 0 If OutlAppointment Is Nothing Then UserForm6 NouveauRDV_Calendrier Else MsgBox "Un Rdv déja prévu à cette date:" & vbCrLf & _ OutlAppointment.Subject End If End Sub
Avez-vous une idée ?

Merci

Stephanie

Bonsoir,

Citation:

la macro m'annonce toujours que "Le contact n'existe pas". Dans le code j'ai ciblé directment sur l'email pour vérifier

Etrange. Sous ma version d'Excel XLS2003 ce code adapté pour une recherche par adresse email fonctionne.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub controle_contactsOutlook()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim adresseEmail As String
 
    adresseEmail = email.Value
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    Set Cible = dossierContacts.Items.Find("[Email1Address] = '" & adresseEmail & "'")
    If Not Cible Is Nothing Then
        MsgBox "Le contact existe déjà dans Ms Outlook"
    Else
        MsgBox "Le contact n'existe pas et donc va être ajouter"
    End If
End Sub

Pour le test de rendez-vous essayer :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub controleRendezVous_contactsOutlook()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.AppointmentItem
    Dim dossierContacts As Outlook.MAPIFolder
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    Dim dateRecherche As Date
    Dim heureRecherche As String
    d = DateValue("21/04/2012")
    heureRecherche = "8:00"
    Set Cible = dossierContacts.Items.Find("[Start] = '" & d & "'")
    If Not Cible Is Nothing Then
        Dim t As Date
        If TimeValue(Cible.Start) = TimeValue(heureRecherche) Then
            MsgBox "Il y a déjà un rendez vous dans Ms Outlook"
        End If
    Else
        MsgBox "Pas de rendez-vous à cette date."
    End If
End Sub

bonjour BlueMonkey et au forum,

- J'ai une piste concernant les contacts. En faite dans outlook, j'ai des dossiers distinguant le type de contact (fournisseurs, clients et contact). Je pense que là je dois surement modifier oldFolderContacts dans

Code:

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

mais je ne sais pas à quoi cela correspond. Dans la création du contact, j'ai ceci

Code:

Set objContact = objOutlook.CreateItem(olContactItem)

J'ai fait un test :
je crée 1 contact dans le dossier par défaut d'Outlook (Contacts) puis essaye de recréer avec le même contact, je devrais avoir le message "Le contact existe" et bien non c'est "Le contact n'existe pas" qui s'affiche à chaque fois
J'ai fais le test sur le numéro de telephone, sur l'email et rien ne change, toujours le même résultat, il créer plusieurs fois le même contact, c'est bizarre !
Je vous reposte les codes ajouter Contact et control contact respectivement :

Code:

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
Sub ajouterContactOutlook()
    'Nécessite d'activer la référence
    'Microsoft Outlook xx.x Object Library
    Dim objOutlook As Outlook.Application
    Dim objContact As ContactItem
 
    'Crée l'instance Outlook
    Set objOutlook = New Outlook.Application
    'Crée un élément pour les contacts
    Set objContact = objOutlook.CreateItem(olContactItem)
 
    'Définit les informations du nouveau contact
    With objContact
        .Email1Address = TextBox4.Text
        .LastName = nom.Text
        .CompanyName = nomEnt.Text
        .HomeTelephoneNumber = TextBox2.Text
        .MobileTelephoneNumber = TextBox3.Text
        .OtherTelephoneNumber = TextBox12.Text
        .HomeAddressStreet = pay.Text
        .HomeAddressCity = ComboBox2.Value
        .Body = TextBox5.Text
        .Categories = ComboBox6.Value
        .Save
    End With
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub controleLastName_contactsOutlook()
Dim olApp As New Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Dim adr As String, leTel As String
 
leTel = TextBox2.Value
 
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'Set olApp = New Outlook.Application
'Set dossierContacts = olApp.getNamespace("MAPI").getDefaultFolder(olFold erContacts)
 
Set Cible = dossierContacts.Items.Find("[Email1Address] = '" & leTel & "'")
If Not Cible Is Nothing Then
MsgBox "Le contact existe"
Else
MsgBox "Le contact n'existe pas"
ajouterContactOutlook
End If
End Sub

Redefinition des dossiers dans Outllook:
Contact pour mes clients et
Fournisseur pour mes fournisseurs

Ou se trouve le problème ?

- Pour les RDV, j'ai fais ce que avez posté

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub RDVExistant()
 
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.AppointmentItem
    Dim dossierContacts As Outlook.MAPIFolder
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    Dim dateRecherche As Date
    Dim heureRecherche As String
    dateRecherche = DateValue("22/04/2012")
    heureRecherche = "8:00"
    Set Cible = dossierContacts.Items.Find("[Start] = '" & dateRecherche & "'")
    If Not Cible Is Nothing Then
        Dim t As Date
        If TimeValue(Cible.Start) = TimeValue(heureRecherche) Then
            MsgBox "Il y a déjà un rendez vous dans Ms Outlook"
        End If
    Else
        MsgBox "Pas de rendez-vous à cette date."
    End If
End Sub

j'ai remplacer "d" par "dateRecherche" mais cela ne change pas. La date que je recherche se trouve dans "TextBox1" et l'heure dans "TextBox4"
Donc, ça donne ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub RDVExistant()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.AppointmentItem
    Dim dossierContacts As Outlook.MAPIFolder
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    Dim dateRecherche As Date
    Dim heureRecherche As String
    dateRecherche = TextBox1.value
    heureRecherche = TextBox4.value
    Set Cible = dossierContacts.Items.Find("[Start] = '" & dateRecherche & "'")
    If Not Cible Is Nothing Then
        Dim t As Date
        If TimeValue(Cible.Start) = TimeValue(heureRecherche) Then
            MsgBox "Il y a déjà un rendez vous dans Ms Outlook"
        End If
    Else
        MsgBox "Pas de rendez-vous à cette date."
    End If
End Sub

Je ne comprends pas le "Dim t as date",
il fait référence à quoi ?

Les 2 tests ne sont pas concluant. Ne trouve pas de doublon et ne créer pas le RDV.
Si il se trompe sur le controle RDV avec message "Pas de rendez-vous à cette date." alors il devrait créer ce RDV, non !

Merci

Stephanie

Bonjour,

Les calendriers et contacts sont associés à un fichier de données personnels.
Il est possible que les contacts et rendez vous ne soient pas dans le dossier par défaut.
Pour le vérifier, essayez d'afficher la liste des contacts et rendez-vous dans la fenêtre de débugage.

Pour les rendez-vous :

Code:

1
2
3
4
5
6
7
8
9
10
11
Sub controleRendezVous_contactsOutlook()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.AppointmentItem
    Dim dossierContacts As Outlook.MAPIFolder
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    For Each Cible In dossierContacts.Items
        Debug.Print "Rendez-vous de <"; Cible.Start & "> à <" & Cible.End & ">"
    Next Cible
End Sub

Pour les contacts :

Code:

1
2
3
4
5
6
7
8
9
10
Sub controle_contactsOutlook()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    For Each Cible In dossierContacts.Items
        Debug.Print Cible.Email1Address
    Next Cible
End Sub

23/04/2012, 09h23
stephadm

bonjour BlueMonkey et au forum,

BlueMonkey , j'ai une message d'alerte qui apparait lorsque j'active controle_contactsOutlook() et rien ne se passe pour controleRendezVous_contactsOutlook()
Le message d'alerte : Un programme essaie d'accéder aux informations d'adresse de messagerie enregistrées dans Outlook...
Autorisation (1,2, 5 et 10minutes)

Merci

Stephanie
23/04/2012, 19h10
BlueMonkey

Bonsoir,

Citation:

J'ai un message d'alerte qui apparait lorsque j'active controle_contactsOutlook()
Un programme essaie d'accéder aux informations d'adresse de messagerie enregistrées dans Outlook

Ben oui, il y a bien une application qui essaye d'accéder aux infos d'outlook.
C'est notre macro ;).
C'est une protection qui permet de détecter/bloquer un accès non souhaité à ces infos.
Ici il faut clairement autoriser l'accès pour que ça fonctionne.

Citation:

rien ne se passe pour controleRendezVous_contactsOutlook()

Si tu as autoriser l'accès aux données pendant un certain temps aux macro
(suite à l'exécution de controle_contactsOutlook),
c'est normal qu'il n'y ait pas le même message d'alerte.
Quand, il ne se passe rien, tu as afficher la fenêtre de d'exécution de débug ?
Parce que la sortie Debug.Print affiche les sorties dans cette fenêtre de débug.
Donc si elle n'est pas affichée, tu ne verras rien.
25/04/2012, 17h21
stephadm

bonjour BlueMonkey et au forum,

BlueMonkey, désolé de ne pas avoir répondu mais je n'ai plus internet pour le moment. Comment fait-on pour afficher cette fenêtre de débug dont vous parler ?

Merci

Stephanie
25/04/2012, 19h32
BlueMonkey

Bonsoir,

Citation:

Comment fait-on pour afficher cette fenêtre de débug

Sous l'éditeur VBA, dans le ruban choisir Affichage, puis Fenêtre d'exécution.