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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
| Option Explicit
' ------------------------------------------------------------------
'Déclaration des tableaux qui recevront les touches à utiliser suivant
' le logiciel de messagerie par défaut du système.
' Déclarés ici, les tableaux ont une portée qui couvre tout le module
Dim TouchesPJ(5) As String, TouchesEnvoi(5) As String
' ------------------------------------------------------------------
' Procédure principale qui compose les éléments du message
' et effectue la demande d'envoi
' c'est cette procédure qui sera appelée par le programme principal (ici Excel)
'
Sub EnvoiEmail(Adresse As String, Objet As String, Corps As String, Optional PJ As String, Optional Cc As String, Optional Bcc As String, Optional Collage As Boolean)
' Remarques : seuls les arguments : Adresse, Objet et Corps sont obligatoires
' l'argument PJ (pièce jointe) est optionnel. S'il est fourni,
' c'est le chemin complet du fichier à joindre qui doit être fourni
' pour joindre plusieurs pièces,
' il faudrait que PJ soit un tableau et qu'il soit traité + bas par une boucle...
' les arguements Cc (copie) et Bcc (copie cachée) sont également facultatifs
' l'argument Collage permet d'indiquer à la procédure si elle doit coller
' le contenu du presse papier dans le corps du message
' Pour Excel, On peut envoyer une plage de cellule au lieu d'une cellule
' en utilisant dans le programme appelant les fonctions PH() ou PT() fournies + bas
'-----------------------------------------------------------------------------
' Quelques exemples d'appel de la procédure EnvoiMail depuis un classeur Excel
'
' Envoi simple sans pièce jointe :
' EnvoiMail Range("A1"), Range("A2"), Range("A3")
' Si les cellules sont nommées :
' EnvoiMail Range("Adresse"),Range("Sujet"),Range("Corps")
' Pour envoyer une plage :
' EnvoiMail Range("Adressse"),Range("Sujet"),PT(Range("A3:A10"))
' En utilisant les arguements nommés (c'est le plus clair):
' EnvoiMail Adresse:= Range("A1"), _
' Objet:= Range("A2"), _
' Corps:= PH(Range("A3:A10")), _
' Collage:= True _
' PJ:= Application.Path & "\AJoindre.jpg" _
' Bcc:="zorro@fantomas.com"
'--------------------------------------------------------------------------------
Dim HyperLien As String ' Reçoit les éléments de l'hyperlien
' composés à partir des arguments fournis à la procédure
Dim i As Integer ' un compteur
Dim Client As Integer
' la syntaxe de base du mailto est la suivante :
' mailto:dest@domaine.bof?Subject=Le sujet du message _
&Body=Le corps du message _
&cc=Destinataire copie _
&bcc=Destinataire copie cachée
HyperLien = "mailto:" & Adresse & "?" ' Le ? introduit les arguments
HyperLien = HyperLien & "Subject=" & Objet & " (à " & Time() & ")"
If Not Collage Then ' (en cas de collage, le corps est ajouté juste avant le collage)
HyperLien = HyperLien & "&Body=" & Corps ' le & sépare les arguments
End If
If Cc <> "" Then HyperLien = HyperLien & "&cc=" & Cc
If Bcc <> "" Then HyperLien = HyperLien & "&bcc=" & Bcc
' Activation du lien
'
ActiveWorkbook.FollowHyperlink HyperLien ' Pour Excel (les autres doivent être en commentaire)
'ThisDocument.FollowHyperlink HyperLien ' Pour Word (les autres doivent être en commentaire)
'Application.FollowHyperlink HyperLien ' Pour Access (les autres doivent être en commentaire)
Attendre 2 ' Appel d'une procédure qui temporise
' c'est à dire que la procédure courante
' (ici EnvoiMail) est suspendue pendant 5s
' cela permet d'Attendre que le client
' de messagerie soit lancé et prêt
' avant d'envoyer les touches
' sinon ce serait le programme appelant
' (ici Excel) qui recevrait les touches
' A REGLER selon votre config
' l'argument de FollowHyperlink se plante au delà de 817 caractères
' donc pour les long messages, on peut utiliser le copier/coller
' C'est le programme appelant qui effectue le COPIER
' (éventuellement même une copie de cellules en tant qu'image : Selection.CopyPicture)
' la présente procédure se contente de COLLER le contenu du presse-papier
' si l'arguement Collage est à True
If Collage Then
' colle puis insère le texte du message au début du message
SendKeys "+{INSERT}", True ' collage
SendKeys "^{HOME}", True ' début du message
SendKeys Corps, True ' envoi du corps du message
SendKeys "{Enter}", True ' ligne suivante
End If
Client = 2 ' 1=Outlook Express
' 2=Mozilla Thunderbird
' 3=Office Outlook
' Suivent des configurations pour d'autres clients de messagerie
' trouvées sur le forum
' 4=Une autre version pour Outlook2003
' 5=Incredimail
' 6=Office Outlook 2007
' 7=...à vous d'ajouter d'autres clients
Select Case Client ' appel du chargement des tableaux des touches selon le
' client de messagerie indiqué
Case 1
OutLookExpress
Case 2
MozillaThunderbird
Case 3
Office2003OutLook
Case 4
Office2003OutLookV2
Case 5
Incredimail
Case 6
Office2007OutLook
Case 7
Office2000OutLook
Case Else
MsgBox "Aucun client de messagerie connu n'est indiqué"
Exit Sub
End Select
' Le traitement de la pièce jointe ne s'exécute que si la procédure à reçu qqchose
' dans l'argument PJ (Optional<=>Facultatif)
If PJ <> "" Then
For i = 1 To TouchesPJ(0) ' dans TouchesPJ(0) on a stocké le nombre de touches
' à envoyer au programme pour joindre une pièce
SendKeys TouchesPJ(i), True ' Envoie les touches d'ajout d'1 pièce jointe
Attendre 1 ' temporise (à règler éventuellement)
Next i
SendKeys PJ, True ' A ce stade le programme Attend un nom de fichier
' on lui envoie
Attendre 1 ' on temporise
SendKeys "{ENTER}", True ' et on valide ce nom de fichier
Attendre 1
End If
For i = 1 To TouchesEnvoi(0)
SendKeys TouchesEnvoi(i), True ' on envoie le message
Next i
End Sub
Sub Attendre(Secondes As Integer)
' Cette procédure temporise pendant le nombre de secondes qu'on lui transmet en argument
Dim Début As Long, Fin As Long, Chrono As Long
Début = Timer
Fin = Début + Secondes
Do Until Timer >= Fin
DoEvents
Loop
End Sub
Sub OutLookExpress()
'Initialisation des tableaux de touches pour Outlook Express
' Pour une pièce jointe
TouchesPJ(0) = 2 ' Nombre de touches nécessaires
TouchesPJ(1) = "%i" ' Appel du menu Insertion par la touche Alt-i
TouchesPJ(2) = "p" ' appel du sous-menu pièce par la touche p
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%s" ' Envoi du message avec Alt-s
End Sub
Sub MozillaThunderbird()
'Initialisation des tableaux de touches pour Mozilla Thunderbird
' Pour une pièce jointe
TouchesPJ(0) = 4 ' Nombre de touches nécessaires
' il semble que l'appel par Alt-f du menu fichier ne marche pas
' à tous les coups donc (merci à FRED65200)
TouchesPJ(1) = "{F10}" ' Appel des menus par {F10}
TouchesPJ(2) = "f" ' Appel du menu Fichier par la touche f
TouchesPJ(3) = "j" ' appel du sous-menu Joindre par la touche j
TouchesPJ(4) = "f" ' appel du sous-sous-menu Fichier par la touche f
' Pour l'envoi du mail
TouchesEnvoi(0) = 4 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%xf" ' choisit l'expéditeur qui commence par F
' à changer bien sur pour votre cas perso
TouchesEnvoi(2) = "^{ENTER}" ' Envoi du message avec Ctrl-Entrée
TouchesEnvoi(3) = "{DOWN}" ' Flèche bas pour choisir l'option "Envoyer en HTML seul"
' dans la boite dialogue
TouchesEnvoi(4) = "{ENTER}" ' confirmation par Entrée
End Sub
Sub Office2003OutLook()
'Initialisation des tableaux de touches pour Office Outlook 2003
' Pour une pièce jointe
TouchesPJ(0) = 2 ' Nombre de touches nécessaires
TouchesPJ(1) = "%i" ' Appel du menu Insertion par la touche Alt-i
TouchesPJ(2) = "f" ' appel du sous-menu fichier par la touche f
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%v" ' Envoi du message avec Alt-v
End Sub
'--------------------------------------------------------
' Voici quelques contributions trouvées sur le forum
' pour d'autres logiciels de messagerie
' merci à leurs auteurs
' par contre, je ne les ai pas vérifiés
'--------------------------------------------------------
Sub Incredimail()
' Contribution de KOLOCO pour Incredimail
' Initialisation des tableaux de touches pour Incrédimail
' Pour une pièce jointe
TouchesPJ(0) = 1 ' Nombre de touches nécessaires
TouchesPJ(1) = "^+a" 'Appel du menu Insertion Fichier par la touche Ctrl+Shift+A
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%s" 'Envoi du message avecAlt-s
End Sub
Sub Office2003OutLookV2()
' Version corrigée par CLARK1978 à essayer si la version d'origine ne gère pas
' la touche Alt-i correctement
' Initialisation des tableaux de touches pour Office Outlook 2003
' Pour une pièce jointe
TouchesPJ(0) = 3 ' Nombre de touches nécessaires
TouchesPJ(1) = "%a" 'Appel du menu Insertion par la touche Alt-a (affichage)
TouchesPJ(2) = "{RIGHT}" ' puis flèche à droite
TouchesPJ(3) = "f" ' appel du sous-menu fichier par la touche f
' Pour l 'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%v" ' Envoi du message avecAlt-v
End Sub
Sub Office2007OutLook()
' Contribution de PC512 pour Office 2007
' Initialisation des tableaux de touches pour Office Outlook 2007
' Pour une pièce jointe
TouchesPJ(0) = 2 ' Nombre de touches nécessaires
TouchesPJ(1) = "%s" ' Appel du menu Insertion par la touche Alt-i
TouchesPJ(2) = "jf" ' appel du sous-menu fichier par la touche f
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%v" 'Envoi du message avecAlt-v
End Sub
Sub Office2000OutLook()
' Contribution de TANATLOC92 pour Office Outlook 2000
' Initialisation des tableaux de touches pour Office Outlook 2000
' Pour une pièce jointe
TouchesPJ(0) = 2 ' Nombre de touches nécessaires
TouchesPJ(1) = "%i" ' Appel du menu Insertion par la touche Alt-i
TouchesPJ(2) = "f" ' appel du sous-menu fichier par la touche f
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "^{ENTER}" ' Envoi du message avec Ctrl-Entrée
End Sub
'----------------------------------------------------------------------------------
' POUR ENVOYER UNE PLAGE DE CELLULES
'----------------------------------------------------------------------------------
' Les fonctions qui suivent sont adaptées à Excel
' elles permettent d'envoyer une plage de cellules plutôt qu'une seule cellule
' elles sont utilisées par le PROGRAMME APPELANT pour préparer le corps du message
' ------------------
' avant de le transmettre à la procédure EnvoiMail
' Première Version:
' Transforme une plage en tableau HTML
' (mais votre programme de messagerie risque de vous demander une confirmation
' pour un envoi de message en HTML, ce qui rompt l'automatisme)
Function PH(LaPlage As Range) As String
' transforme une plage en tableau HTML
Dim l As Long, c As Long
PH = "<html><table width='100%'>" 'balises de début du code HTML et de début de table
For l = 1 To LaPlage.Rows.Count ' pour chaque ligne de la plage
PH = PH & "<tr>" ' balise de début de ligne
For c = 1 To LaPlage.Columns.Count 'pour chaque colonne de la ligne
' balise début de colonne + contenu de la cellule + balise fin de colonne
PH = PH & "<td>" & LaPlage.Cells(l, c) & "</td>"
Next c
PH = PH & "</tr>" ' balise fin de ligne
Next l
PH = PH & "</table></html>" ' balises de fin de table et de fin de code HTML
'MsgBox PH
End Function
' Deuxième Version:
' Transforme une plage en texte délimité avec Tabulations
Function PT(LaPlage As Range) As String
' transforme une plage en texte avec tabulations et retours ligne
Dim l As Long, c As Long
PT = ""
For l = 1 To LaPlage.Rows.Count
For c = 1 To LaPlage.Columns.Count
PT = PT & LaPlage.Cells(l, c)
If c < LaPlage.Columns.Count Then
' on ajoute une tabulation que si on n'est pas sur la dernière colonne
PT = PT & "%09" ' %09 est le code pour la tabulation (vbTab ne fonctionne pas ici)
End If
Next c
PT = PT & "%0A" ' %0A est le code pour le retour ligne (vbCrLf ne fonctionne pas ici)
Next l
'MsgBox PT
End Function
'---------------------------------------------------------------------------
'Autre méthode totalement différente et indépendante mais qui ne fonctionne
' QU'AVEC OUTLOOK. Elle fait appel à la technologie Automation (OLE)
' il faut ajouter la bibliothèque "Microsoft Outlook 11.0 Object Library"
' à votre projet
' son avantage principal : la fenêtre Outlook ne s'ouvre pas !!!
' autre avantage : c'est un peu plus élégant
' (merci à JeanMimi75)
' Pour le programme appelant l'utilisation est identique, il suffit de changer
' le nom de la procédure appelée (EnvoiMailMéthodeOLE au lieu de EnvoiEmail)
' par exemple :
' En utilisant les arguements nommés (c'est le plus clair):
' EnvoiMailMéthodeOLE Adresse:= Range("A1"), _
' Objet:= Range("A2"), _
' Corps:= PH(Range("A3:A10")), _
' PJ:= Application.Path & "\AJoindre.jpg" _
' Bcc:="zorro@fantomas.com"
' Attention avec cette technique, le collage du contenu du presse-papier n'est pas géré
'----------------------------------------------------------------------------
Sub EnvoiMailMéthodeOLE(Adresse As String, Objet As String, Corps As String, Optional Pièce As String, Optional Cc As String, Optional Bcc As String)
Dim MonAppliOutlook As New Outlook.Application
Dim MonMail As Outlook.MailItem
Dim MaPièce As Outlook.Attachments
Set MonMail = MonAppliOutlook.CreateItem(olMailItem)
With MonMail
'.Display ' retirer le commentaire si vous voulez que le fenêtre Outlook s'affiche
.To = Adresse
If Not IsNull(Cc) Then .Cc = Cc
If Not IsNull(Bcc) Then .Bcc = Bcc
.Subject = Objet
.Body = Corps
If Not IsNull(Pièce) Then
Set MaPièce = .Attachments
MaPièce.Add Pièce, olByValue
End If
.Send
End With
End Sub |
Problème formule lien hypertexte mail contenu cellule
Répondre avec citation
Partager