Exécuter du code à l'ouverture et fermeture d'outlook [Résolu]

[sebinator]

Bonjour à tous,

J'ai un code en vba (cf tuto partage de contact sans exchange).

Actuellement j'ai un bouton dans ma barre de menu qui me permet de l'éxécuter.

Je souhaite que le code s'éxécute à l'ouverture et à la fermeture d'outlook de maniere automatique.

Comment fait-on ?

Merci d'avance

Seb

[Oliv-]

SAlut,

tu peux laisser ta macro où elle est et dans ThisOutlookSession il faut utiliser les événements qui vont bien :

Au lancement :

Code :

1
2
3
Private Sub Application_Startup()
tamacro
end sub

A la fermeture

Code :

1
2
3
Private Sub Application_Quit()
tamacro
end sub

Attention aux erreurs qui pourraient empecher outlook de se fermer correctement.

Pour l'ouverture de outlook l'idéal est de "signer electroniquement" ton code pour éviter d'accepter les macros à chaque fois.

[Dolphy35]

Salut,

pensé à consulter la page de cours, il y a des tutos intéressants qui répondent souvent aux questions

http://outlook.developpez.com/cours/

tuto en question :

Initiation au VBA d'Outlook


Dolphy

[sebinator]

Merci pour vos réponses,

J'utilise le tuto "comment partager les contacts sans exchange"

Il y a un comportement bizarre...

J'ai ajouté ParcourirContact et MettreAJourContact dans Application_Startup et Application_Quit et le probleme c'est qu'il m'ajoute sans cesse les mêmes fiches dans la base access.

De plus, à chaque fois que j'ouvre outlook, il affiche la boite de configuration (install office) outlook. Est-ce normal ?

seb

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
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
Option Explicit
Public Sub ParcourirContact()
'*************************************************************************
' Routine qui va parcourir les enregistrements présents dans le répertoire
' contacts et copier les enregistrements manquants dans la base de données
' Macro crée pour article DVP par Olivier Lebeau
'*************************************************************************
Dim oCont As ContactItem
Dim oFold As Folder
Dim nM As NameSpace
Dim olApp As Outlook.Application
Dim i As Integer
Dim j As Integer
 
j = 1
' Affectation des objets
Set olApp = Outlook.Application
Set nM = olApp.GetNamespace("MAPI")
Set oFold = nM.GetDefaultFolder(olFolderContacts)
 
i = oFold.Items.Count
' Boucle pour parcourir les contacts locaux
For j = 1 To i
    ' Appel à la fonction AccesADB avec comme paramètre le contactItem
    AccesADB (oFold.Items(j))
Next j
End Sub
 
Public Function AccesADB(mycont As ContactItem)
'**************************************************************************
' Fonction appelée pour envoyer vers la base de données les nouveaux
' contacts
' Fonction écrite pour article DVP par Olivier Lebeau
'**************************************************************************
On Error Resume Next
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String
sql = "SELECT Contacts.*, Contacts.Nom, Contacts.[Prénom] "
sql = sql & " FROM Contacts "
sql = sql & " Where Contacts.Nom = """ & mycont.LastName
sql = sql & """ AND Contacts.[Prénom] = """ & mycont.FirstName & """;"
' Debug.Print sql
' Vous devez spécifier le chemin complet de votre base de données
Set db = OpenDatabase("E:\TempACC\contacts.mdb")
Set rs = db.OpenRecordset(sql)
' Debug.Print rs.RecordCount
'**********************************************************************
' La liste des champs traités peut être augmentée en fonction de vos
' besoins. Par facilité, je n'ai volontairement mis que 3 champs
' Si vous rencontrez des problèmes avec les lignes Fields("xxxxx")
' je vous conseille d'utiliser l'index du champ Fields(2)
'**********************************************************************
 
If rs.RecordCount = 0 Then
    rs.AddNew
    rs.Fields("Nom") = Nz(mycont.LastName, " ")
    rs.Fields("Prénom") = Nz(mycont.FirstName, " ")
    rs.Fields("Adresse de messagerie") = mycont.Email1Address
    rs.Fields("Société") = Nz(mycont.CompanyName, " ")
    rs.Update
End If
'**********************************************************************
' Libération des objets
'**********************************************************************
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Function
 
Public Sub MettreAJourContact()
'******************************************************************************
' Procédure pour récupérer les enregistrements présents dans la base de
' données et les injecter dans le répertoire contact.
'******************************************************************************
On Error Resume Next
Dim oCont As ContactItem
Dim oCo As ContactItem
Dim oFold As Folder
Dim nM As NameSpace
Dim olApp As Outlook.Application
Dim stFilt As String
Dim rs As DAO.Recordset
Dim db As DAO.Database
 
'******************************************************************************
' Affectation des objets
'******************************************************************************
 
Set db = OpenDatabase("E:\TempACC\contacts.mdb")
Set rs = db.OpenRecordset("Select * From Contacts")
Set olApp = Outlook.Application
Set nM = olApp.GetNamespace("MAPI")
Set oFold = nM.GetDefaultFolder(olFolderContacts)
'******************************************************************************
' Boucle pour parcourir les enregistrements de la table
'******************************************************************************
 
While Not rs.EOF
'Filtre pour recherche des données déjà existantes dans les contacts locaux
stFilt = "[FirstName] = """ & rs.Fields("Prénom")
stFilt = stFilt & """ And [LastName] = """ & rs.Fields("Nom") & """"
' Recherche avec filtre
Set oCo = oFold.Items.Find(stFilt)
' procédure décisionnelle pour copie des données
If oCo = "Nothing" Then
    ' Si pas de données, on les ajoute
    Set oCont = oFold.Items.Add
        oCont.FirstName = rs.Fields("Prénom")
        oCont.LastName = rs.Fields("Nom")
        oCont.Email1Address = rs.Fields("Adresse de messagerie")
        oCont.CompanyName = rs.Fields("Société")
        oCont.Save
End If
' Déplacement vers l'enregistrement suivant.
rs.MoveNext
Wend
' Libération des objets
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Sub

[sebinator]

j'ai compris et surtout j'ai relu les commentaires dans le tuto

mon soucis se situe sur l'interprétation des noms de champs :

rs.Fields("Nom")

J'ai remplacé le nom par l'index du champ et cela fonctionne.