Discussion :

[mans39]

Bonjour,
J'aimerais créer une macro qui permettrait de copier les contacts de l'entreprise qui se trouvent dans les dossiers publics pour ensuite les coller dans les contacts outlook.
Cela pour éviter aux personnes de le faire manuellement à chaque arriver ou départ de personnes.
J'ai des bases de programmation en VB donc si le code n'est pas trop complexe je suis attentif à toutes propositions.
Merci!

[Dolphy35]

Salut,

je ne suis pas expert en Exchange mes les dossiers publics servent à cela justement ?


Dolphy

[raphaeldavid]

Pour débuter, j'ai trouvé ce script qui est en partie la réponse...

Lancer une macro au démarrage d'outlook

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
Application_Startup()
 
Sub ajout_contacts()
Dim oOL As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oRestricted As Outlook.Items
Dim oFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim nombre As Integer
Dim citem
Dim oemployee As Outlook.ContactItem
   Set oOL = New Outlook.Application
   Set oemployeefolder = oOL.GetNamespace("MAPI").Folders("Dossiers publics")
   Set oemployeefolder = oemployeefolder.Folders("Tous les dossiers publics")
   Set oemployeefolder = oemployeefolder.Folders("Contacts Entreprise")               <-- Répertoire source
nombre = 0
 
    Set oOL = GetObject(, "Outlook.Application")
    If oOL Is Nothing Then
        Set oOL = CreateObject("Outlook.Application")
    End If
    Set oNS = oOL.GetNamespace("MAPI")
    Set oContact = oOL.CreateItem(olContactItem)
    Set oFolder = oNS.GetDefaultFolder(olFolderContacts)
For Each citem In oemployeefolder.Items
 
    If comparer(citem.FileAs) = False Then
    Set oOL = GetObject(, "Outlook.Application")
    If oOL Is Nothing Then
        Set oOL = CreateObject("Outlook.Application")
    End If
    Set oNS = oOL.GetNamespace("MAPI")
    Set oContact = oOL.CreateItem(olContactItem)
    Set oFolder = oNS.GetDefaultFolder(olFolderContacts)
    Set oItems = oFolder.Items
 
    'For Each objcontactitem.ContactItem.olContactItem In oContact
     With oContact
        '.FullName = citem.FullName
        '.HomeAddress = "AdresseSamples"
        .Account = citem.Account
.Anniversary = citem.Anniversary
.AssistantName = citem.AssistantName
.AssistantTelephoneNumber = citem.AssistantTelephoneNumber
.BillingInformation = citem.BillingInformation
.Birthday = citem.Birthday
.Body = citem.Body
.BusinessTelephoneNumber = citem.BusinessTelephoneNumber
.BusinessFaxNumber = citem.BusinessFaxNumber
.Business2TelephoneNumber = citem.Business2TelephoneNumber
.BusinessAddressPostOfficeBox = citem.BusinessAddressPostOfficeBox
.BusinessAddressState = citem.BusinessAddressState
.BusinessAddressStreet = citem.BusinessAddressStreet
.BusinessHomePage = citem.BusinessHomePage
.CallbackTelephoneNumber = citem.CallbackTelephoneNumber
.CarTelephoneNumber = citem.CarTelephoneNumber
.Categories = citem.Categories
.Children = citem.Children
.Companies = citem.Companies
.CompanyName = citem.CompanyName
.ComputerNetworkName = citem.ComputerNetworkName
.CustomerID = citem.CustomerID
.Department = citem.Department
.Email1Address = citem.Email1Address
.Email1AddressType = citem.Email1AddressType
.Email2Address = citem.Email2Address
.Email2AddressType = citem.Email2AddressType
.Email3Address = citem.Email3Address
.Email3AddressType = citem.Email3AddressType
.FileAs = citem.FileAs
.FirstName = citem.FirstName
.FormDescription = citem.FormDescription
.FTPSite = citem.FTPSite
.FullName = citem.FullName
.Gender = citem.Gender
.GetInspector = citem.GetInspector
.GovernmentIDNumber = citem.GovernmentIDNumber
.Hobby = citem.Hobby
.Home2TelephoneNumber = citem.Home2TelephoneNumber
.HomeAddress = citem.HomeAddress
.HomeAddressCity = citem.HomeAddressCity
.HomeAddressCountry = citem.HomeAddressCountry
.HomeAddressPostalCode = citem.HomeAddressPostalCode
.HomeAddressPostOfficeBox = citem.HomeAddressPostOfficeBox
.HomeAddressState = citem.HomeAddressState
.HomeAddressStreet = citem.HomeAddressStreet
.HomeFaxNumber = citem.HomeFaxNumber
.HomeTelephoneNumber = citem.HomeTelephoneNumber
.Importance = citem.Importance
.Initials = citem.Initials
.InternetFreeBusyAddress = citem.InternetFreeBusyAddress
.ISDNNumber = citem.ISDNNumber
.JobTitle = citem.JobTitle
.Journal = citem.Journal
.Language = citem.Language
.LastName = citem.LastName
.MailingAddress = citem.MailingAddress
.MailingAddressCity = citem.MailingAddressCity
.MailingAddressCountry = citem.MailingAddressCountry
.MailingAddressPostalCode = citem.MailingAddressPostalCode
.MailingAddressPostOfficeBox = citem.MailingAddressPostOfficeBox
.MailingAddressState = citem.MailingAddressState
.MailingAddressStreet = citem.MailingAddressStreet
.ManagerName = citem.ManagerName
.MessageClass = citem.MessageClass
.MiddleName = citem.MiddleName
.Mileage = citem.Mileage
.MobileTelephoneNumber = citem.MobileTelephoneNumber
.NetMeetingAlias = citem.NetMeetingAlias
.NetMeetingServer = citem.NetMeetingServer
.NickName = citem.NickName
.NoAging = citem.NoAging
.OfficeLocation = citem.OfficeLocation
.OrganizationalIDNumber = citem.OrganizationalIDNumber
.OtherAddress = citem.OtherAddress
.OtherAddressCity = citem.OtherAddressCity
.OtherAddressCountry = citem.OtherAddressCountry
.OtherAddressPostalCode = citem.OtherAddressPostalCode
.OtherAddressPostOfficeBox = citem.OtherAddressPostOfficeBox
.OtherAddressState = citem.OtherAddressState
.OtherAddressStreet = citem.OtherAddressStreet
.OtherFaxNumber = citem.OtherFaxNumber
.OtherTelephoneNumber = citem.OtherTelephoneNumber
.PagerNumber = citem.PagerNumber
.PersonalHomePage = citem.PersonalHomePage
.PrimaryTelephoneNumber = citem.PrimaryTelephoneNumber
.Profession = citem.Profession
.RadioTelephoneNumber = citem.RadioTelephoneNumber
.ReferredBy = citem.ReferredBy
.SelectedMailingAddress = citem.SelectedMailingAddress
.Sensitivity = citem.Sensitivity
.Spouse = citem.Spouse
.Subject = citem.Subject
.Suffix = citem.Suffix
.TelexNumber = citem.TelexNumber
.Title = citem.Title
.TTYTDDTelephoneNumber = citem.TTYTDDTelephoneNumber
.UnRead = citem.UnRead
.User1 = citem.User1
.User2 = citem.User2
.User3 = citem.User3
.User4 = citem.User4
.UserCertificate = citem.UserCertificate
.WebPage = citem.WebPage
.YomiCompanyName = citem.YomiCompanyName
.YomiFirstName = citem.YomiFirstName
.YomiLastName = citem.YomiLastName
 
    oContact.Save
    Set oContact = Nothing
    Set oFolder = Nothing
    Set oItems = Nothing
nombre = nombre + 1
 
End With
End If
Next
afic = MsgBox("Ajout de " & nombre & " contacts", vbCritical, "Contacts manager")               <-- Message de confirmation à la fin que j'aimerais bien enlevé.
End Sub
 
Function comparer(nomcomplet)
Dim str1Input
Dim str2Input
Dim ditem
Dim strOutput
    str1Input = nomcomplet
    'str2Input = prenomcomplet
    Set objOutlook = CreateObject("Outlook.application")
    Set objNameSpace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
 
    For Each ditem In objFolder.Items
        If (ditem.FileAs = str1Input) Then                <-- Pour ma part, le script arrête ici lorsque je l'exécute, la comparaison ne fonctionne pas
            'If (ditem.LastName = str2Input) Then
 
        comparer = True
        Exit Function
 
        End If
 'End If
 
    Next
  If strOutput = "" Then
    comparer = False
 
 
  End If
End Function

Laisse-moi savoir si tu fini par le faire fonctionner... je travaille aussi de mon côté.

J'ai essayé le script sans la fonction de comparaison et ça fonctionne, mais ce n'est pas pratique, car il n'y a pas de synchronisation, les contacts publics écrasent les privés.

L'auteur du script a écrit une note que je n'ai pas essayé, car ça ne s'applicaque pas dans mon cas

La syncronisation des carnet d'adresse chez microsoft est un casse tete, il est possible de forcer outlook express, ainssi que le telecopieur a utiliser le carnet d'adresse de Outlook 200X, mais pas les carnet d'adresse de l'entreprise d'ou le devellopement de cette macro.
(HKCU/software/Microsoft/Wab/WAB4/UseOutlook = 1)