Discussion :

[foudhil92]

Bonjour à tous,

Je sollicite votre car j'ai un problème que je n'arrive pas à résoudre, par avance merci pour votre aide.
Voilà je veux via VBA créer un contact mais pas dans le répertoire par défaut qui est "Contacts" mais dans le groupe "Contacts partagés" dans mon sous répertoire "test".
J'ai un code (ci-dessous) qui ajoute bien le contact dans le répertoire par défaut "Contacts" mais je ne sais pas comment modifier ce code pour que le contact soit ajouté dans le répertoire "test" du groupe "Contacts partagés".
Comment modifier ce code pour arriver au résultat souhaité ?
Merci.

*********************

Sub cont()

Const olContactItem = 2

Set objOutlook = CreateObject("Outlook.Application")
Set objContact = objOutlook.CreateItem(olContactItem)

objContact.FullName = "AAA"
objContact.Email1Address = "kenmyer@fabrikam.com"
objContact.CompanyName = "Fabrikam"
objContact.JobTitle = "Administrateur réseau"
objContact.HomeTelephoneNumber = "555-555-8888"
objContact.HomeAddress = "3725 205th NE" & vbCrLf & "Redmond, WA 98052"
objContact.Birthday = "9/15/1966"

objContact.Save

End Sub

[Oliv-]

Bonjour,

Il y a 2 solutions la première à la fin de Ta macro tu déplace le contact dans le bon dossier avec la méthode .move

L'autre c'est de se positionner dans le dossier et de faire un .add

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
27
28
29
30
31
32
33
34
 
Sub NouveauContactDossierContactsPartages()
'---------------------------------------------------------------------------------------
' Procedure : DossierContactsPartages
' Author    : OLIV
' Date      : 17/11/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objNS As Outlook.NameSpace
    Dim objExpCtct As Outlook.Explorer
    Dim objNavMod As Outlook.ContactsModule
    Dim objNavCalPart As Outlook.NavigationFolders
    Dim DossierContacts
    Set objNS = Application.Session
    Set objExpCtct = objNS.GetDefaultFolder(olFolderContacts).GetExplorer
    Set objNavMod = objExpCtct.NavigationPane.Modules.GetNavigationModule(olModuleContacts)
    Set objNavCalPart = objNavMod.NavigationGroups.item("Contacts partagés").NavigationFolders
    Set DossierContacts = objNavCalPart("test").Folder
 
    Set objContact = DossierContacts.Items.add(olContactItem)
    objContact.FullName = "AAA"
    objContact.Email1Address = "kenmyer@fabrikam.com"
    objContact.CompanyName = "Fabrikam"
    objContact.JobTitle = "Administrateur réseau"
    objContact.HomeTelephoneNumber = "555-555-8888"
    objContact.HomeAddress = "3725 205th NE" & vbCrLf & "Redmond, WA 98052"
    objContact.Birthday = "9/15/1966"
 
    objContact.Save
 
 
    Stop
End Sub

[foudhil92]

Bonjour Oliv-

Merci de ton aide, cela fonction exactement comme je le voulais.
Merci encore.

A bientôt

[foudhil92]

Un autre problème après la première solution.
J'ai voulu appliquer le code de Oliv qui fonctionne bien sous outlook mais pas sous excel.
En fait j'ai un tableau avec 3 colonne (Nom, Entrepris et Adresse mail), le problème c'est que j'ai une erreur à la première ligne "Type défini par l'utilisateur non défini". Je pense que l'erreur est du au fait que je e lance pas la macro sous outlook mas sous excel.
Auriez-vous une idée ?
Merci.

Code sous Excel:

Sub NouveauContactDossierContactsPartages()

Dim objNS As Outlook.Namespace
Dim objExpCtct As Outlook.Explorer
Dim objNavMod As Outlook.ContactsModule
Dim objNavCalPart As Outlook.NavigationFolders
Dim DossierContacts
Set objNS = Application.Session
Set objExpCtct = objNS.GetDefaultFolder(olFolderContacts).GetExplorer
Set objNavMod = objExpCtct.NavigationPane.Modules.GetNavigationModule(olModuleContacts)
Set objNavCalPart = objNavMod.NavigationGroups.Item("Contacts partagés").NavigationFolders
Set DossierContacts = objNavCalPart("test").Folder

Set objExcel = CreateObject("Excel.Application")


x = 1

Boucle:

If Cells(x, 1).Value = "" Then GoTo fin

Set objContact = DossierContacts.Items.Add(olContactItem)
objContact.FullName = Cells(x, 1).Value
objContact.Email1Address = Cells(x, 3).Value
objContact.CompanyName = Cells(x, 3).Value

objContact.Save

x = x + 1
GoTo Boucle

fin:
objExcel.Quit

End Sub

[Oliv-]

Il faut déterminer qui lance le code OUTLOOK ou EXCEL.

Ensuite il faut ajouter dans VBE / OUTILS / REFERENCES
Microsoft outlook 1x.0 object library
ou
Microsoft Excel 1x.0 object library

c'est pour avoir les constantes de l'autre programme celui qu'on contrôler.

Si tu lances le code à partir de EXCEL

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 Dim olApp As Outlook.Application
    If Application.NAme = "Outlook" Then
        Set olApp = Application
    Else
        Set olApp = CreateObject("outlook.application")
    End If

et au lieu d'avoir

Set objNS = Application.Session
tu devras mettre

Set objNS = olApp.Session

[foudhil92]

Bonjour,

Avant tout merci pour ton aide Oliv, j'ai pu solutionner beaucoup de problème.

Mais j'en ai malheureusement un autre. Voilà j'ai récupérer le code qui fonctionne bien suivant pour supprimer un contact Outlook, mais je ne sais pas comment l'adapter pour qu'il supprime le contact dans mon groupe "test" et pas dans le groupe contact par défaut d'Outlook. J'aimerais aussi savoir quel commande je dois mettre si j veux utiliser le même code mais cette fois-ci pas pour supprimer un contact de me groupe "test" mais pour le modifier.

Merci pour votre aide.

Le code:

Sub DeleteaContact()

Dim myOutlook As Outlook.Application
Dim myInformation As Namespace
Dim myContacts As Items
Dim myItems As ContactItem

Set myOutlook = CreateObject("Outlook.Application")
Set myInformation = myOutlook.GetNamespace("MAPI")
Set myContacts = myInformation.GetDefaultFolder(olFolderContacts).Items

For Each myItems In myContacts
If myItems.FullName = "BBBBB" Then
myItems.Delete
End If
Next

End Sub

[Oliv-]

Bonjour,

Quel contact veux tu supprimer ? celui qui est actuellement ouvert ? un contact que tu vas rechercher à partir de son nom ? autre...?

[foudhil92]

Bonjour,

Quel contact veux tu supprimer ? celui qui est actuellement ouvert ? un contact que tu vas rechercher à partir de son nom ? autre...?

Un contact que je vais rechercher par son nom.

[Oliv-]

Pour te positionner dans le dossier partagé c'est le même code que précédemment

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Set objNS = Application.Session
    Set objExpCtct = objNS.GetDefaultFolder(olFolderContacts).GetExplorer
    Set objNavMod = objExpCtct.NavigationPane.Modules.GetNavigationModule(olModuleContacts)
    Set objNavCalPart = objNavMod.NavigationGroups.item("Contacts partagés").NavigationFolders
    Set DossierContacts = objNavCalPart("test").Folder

ensuite tu vas rechercher ton Contact.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
   Dim searchContacts As Items
    Set searchContacts = DossierContacts.Items
    Dim filter
    filter = "@SQL=" & Chr(34) & _
             "urn:schemas:contacts:cn" _
           & Chr(34) & " like '%" & Fullname & "%'"
 
    Set fc_searchContacts = searchContacts.Restrict(filter)

puis tu vas parcourir les éléments renvoyés par ta recherche

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Dim i
    For i = fc_searchContacts.Count To 1 Step -1
        fc_searchContacts(i).Delete
    Next i

[foudhil92]

Ou dois-je indiquer le nom du contact dans le code ci-dessous ? Car si je remplace "urn:schemas:contacts:cn" par le nom de conctat "toto" par exemple cela supprime bien le contact dans mon groupe mais cela supprime tous les autres contacts aussi.

Dim searchContacts As Items
Set searchContacts = DossierContacts.Items
Dim filter
filter = "@SQL=" & Chr(34) & _
"urn:schemas:contacts:cn" _
& Chr(34) & " like '%" & FullName & "%'"

[foudhil92]

C'est bon j'ai remplacé le deuxième code par

Dim sfilter
sFullName = "toto"
sfilter = "[FullName] = " & Chr(34) & sFullName & Chr(34)

Set fc_searchContacts = searchContacts.Restrict(sfilter)


Merci.

[Oliv-]

Tu as juste besoin de déclarer

Fullname ="toto"

ps: merci de ne pas envoyer de MP , je consulte régulièrement le forum.

[foudhil92]

Bonjour,

Je suis en train de finaliser mon code et je tombe sur un nouveau problème. Comment ajouter plusieurs catégories différentes lors de la création du contact. Sur mon code ci-dessous il cré qu'une seule catégorie avec la dernière valeur. C'est à dire qu'à la fin il y a qu'une catégorie dans mon contact est qui porte le nom contenu dans TextBox_Categorie5.
Comment faire pour qu'il me cré la catégorie 1, puis 2, puis 3 puis 4 et enfin 5 ?

Merci pour votre aide.

Set objContact = DossierContacts.Items.Add(olContactItem)

objContact.CompanyName = Cells(x, 1).Value
objContact.BusinessAddressStreet = TextBox_Rue
objContact.BusinessAddressCity = TextBox_Ville
objContact.BusinessAddressPostalCode = TextBox_Code_Postal
objContact.FirstName = TextBox_Nom_Cn
objContact.LastName = TextBox_Prenom_Cn
objContact.Suffix = " - " & TextBox_Nom_Entreprise
objContact.JobTitle = Cells(x, y + 1).Value
objContact.BusinessTelephoneNumber = Cells(x, y + 2).Value
objContact.BusinessFaxNumber = Cells(x, y + 3).Value
objContact.MobileTelephoneNumber = Cells(x, y + 4).Value
objContact.Email1Address = Cells(x, y + 5).Value
objContact.WebPage = Cells(x, 15).Value

If TextBox_Categorie1.Value <> "" Then
objContact.Categories = TextBox_Categorie1
objContact.Body = TextBox_Categorie1
Else
End If
If TextBox_Categorie2 <> "" Then
objContact.Categories = TextBox_Categorie2
objContact.Body = TextBox_Categorie1 & ", " & TextBox_Categorie2
Else
End If
If TextBox_Categorie3 <> "" Then
objContact.Categories = TextBox_Categorie3
objContact.Body = TextBox_Categorie1 & ", " & TextBox_Categorie2 & ", " & TextBox_Categorie3
Else
End If
If TextBox_Categorie4 <> "" Then
objContact.Categories = TextBox_Categorie4
objContact.Body = TextBox_Categorie1 & ", " & TextBox_Categorie2 & ", " & TextBox_Categorie3 & ", " & TextBox_Categorie4
Else
End If
If TextBox_Categorie5 <> "" Then
objContact.Categories = TextBox_Categorie5
objContact.Body = TextBox_Categorie1 & ", " & TextBox_Categorie2 & ", " & TextBox_Categorie3 & ", " & TextBox_Categorie4 & ", " & TextBox_Categorie5
Else
End If

[Oliv-]

Salut,
les catégories sont simplement concaténées avec un ; comme séparateur
At.Categories = "Catégorie Jaune; Catégorie rouge"

[foudhil92]

Salut,
les catégories sont simplement concaténées avec un ; comme séparateur
At.Categories = "Catégorie Jaune; Catégorie rouge"

Merci pour ta réponse Oliv-.
Mais justement je ne veux pas qu'il concate les catégories. Je veux créer plusieurs catégories avec des noms différents pour un même contact, comme quand tu as un contact et que tu ajoutes une catégorie dans "Categories" puis "Nouveau".

Merci.

[Oliv-]

c'est la seule solution, testes et tu verras que tu auras bien visuellement plusieurs catégories sur ton contact.