Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter
Envoyer un mail avec pièce jointe
Bonjour à tous !
J'ai besoin de votre aide pour créer un code VBA me permettant d'envoyer, à plusieurs destinataires, des fichiers excel par mail (outlook).
Le mail devant avoir un corps de texte.
J'ai regardé quelques discussions sans trouver de réponses à mon problème, je ne sais pas par où commencer !
Merci de votre aide !!
Bonsoir,
voici une exemple
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Merci de votre aide, je vais essayer cette méthode !
Bonjour tout le monde,
Je me permet de relancer cette discutions pour avoir plus de précision. Je souhaiterais mettre en place dans une feuille :
Plusieurs destinataire du mail (ligne 1, 2, 3, 4 etc) qui peut être variable (de A2 à AX)
Idem pour ceux en CC
Idem pour les pièces jointes auquel je pourrais avoir plusieurs fichiers (le nom de mes fichiers se trouve de B7 jusqu'a BX et il peut y en avoir qu'un)
Pourriez-vous me dire également comment modifier la police d'écriture ? Avec le code ca me met par défaut times news roman taille 12 au lieu de arrial 10 qui est par défaut.
J'ai réussi à contourner le problème pour les destinataires en envoyant un mail à chaque destinataire mais ce n'est pas ce que je souhaite. Par contre pour les divers pièces jointes je ne sais pas trop comment faire.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Essaye de comprendre et d'adapter le code au #2
https://www.developpez.net/forums/d1...e/#post9886481
Envoyé par Oliv-
Salut Oliv,
Je ne comprends pas ton message. Quand je clique sur le lien ça me redirige nul part.
Si dans la même page plus haut
Bonjour Oliv
J’essaie votre code sans y arriver à y apporter des corrections (niveau trop faible), et conséquence AVC en fin d'année ça ne me surprend pas.
Je désire envoyer directement à partir d'Excel un mail avec pièce jointe en .zip - Si possible sans afficher la page Outlook
En vous remerciant très chaleureusement pour l'aide que vous m'apporterez surtout avec un code fonctionnel.
L'adresse mail de l'expéditeur se trouve en J13 (La feuille Excel se nomme : FR
Les destinataires en zone nommée Dest'Soit 5 destinataires au total
L'objet : Mise à jour de l'annuaire_APEM
Corps de texte : Veuillez trouver ci-joint un dossier pour la mise à jour.
Jean
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Bonjour Jean , Navré pour cet AVC (j'espère quand même que c'était de l'humour !).
voici un code qui devrait fonctionner à lancer à partir d'excel.
l'envoi "au nom de" ( .SentOnBehalfOfName = Worksheets("FR").Range("J13")) peut ne fonctionner selon ta configuration de messagerie.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Bonjour oliv
Merci de me répondre cher ami
Hélas non ce n'était pas de l'humour mais que la triste réalité et qui, de plus, m'empêche de raisonner sainement
De plus ce n'est pas le classeur actif que je désire envoyer mais un dossier.zip présent à l'écran crée par macro
Le problème étant que je doit si je me rappelle bien utiliser %userprofil% ou quelque chose comme ça
oui c'est bien ce que j'ai programmé , l'envoi de "NouvelFiche.zip" qui doit se trouver sur le bureau.
Merci beaucoup Oliv car les destinataires de la fiche, une centaine ou plus peuvent avoir un emplacement différent
Je te souhaite une bonne journée
Re
J'ai un problème dans ce code a la ligne :
Code : Sélectionner tout - Visualiser dans une fenêtre à part CompresserNouvelFiche chDos, chDos & Environ("username") & ".zip"
Accepterais-tu de le corriger Stp
Il me faut juste NouvelFiche.zip
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Bonjour Oliv
Bon, j'avance tout doucement mais j'avance grâce a toi
J'ai cependant un dernier petit problème, c'est que le mail est transmis deux fois et je ne vois pas d’où ça vient
Je te mets le code et te remercie d'apporter la correction nécessaire
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Bonjour Jean,
Avec cette partie de code je ne vois pas, il faudrait le code complet.
tu as donc réglé ton problème d'emplacement de NouvelFiche.zip ?
Merci Oliv, voici les codes :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
286FeuilFR Sub CompresserNouvelFiche(ByVal DSrc, ByVal DDst) Const ForAppending = 8 Dim FSO As Object, shApp As Object, Fld As Object, Dzip As Object, Hx, Bx, i% Hx = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) For i = 0 To UBound(Hx) Bx = Bx & Chr(Hx(i)) Next i Set FSO = CreateObject("Scripting.FileSystemObject") Set Dzip = FSO.CreateTextFile(DDst, True) Dzip.Write Bx Dzip.Close Set shApp = CreateObject("Shell.Application") Set Fld = shApp.Namespace(DSrc) If Not Fld Is Nothing Then shApp.Namespace(DDst).copyhere Fld.Items Set Dzip = Nothing '--- il faut attendre un moment sinon bug et fichier zip vide Sleep 2000 '--- 2 secondes --- voir en Module1 On Error Resume Next Do While Dzip Is Nothing Set Dzip = FSO.OpenTextFile(DDst, ForAppending, False) If Err.Number <> 0 Then Err.Clear Loop ' MsgBox "La transmission de votre dossier a été réalisé avec succès", vbInformation TransMail MsgBox "La transmission de votre dossier a été réalisé avec succès", vbInformation End Sub Sub EffacerFiche() Dim Fiche, i% Fiche = Split("A2 A4 K4 S4 A7 K7 S7 E9 K9 Q9 A10 G10 M10 S10 J13 F14 A18 S18 A21 S21 " _ & "A24 G24 W25 A29 W30 A34 S34 A37 C41 I41 X41 AA41 Y47 AB2") With Worksheets("FR") For i = 0 To UBound(Fiche) .Range(Fiche(i)).MergeArea.ClearContents Next i End With End Sub Private Sub Annuaire() Dim wsA As Worksheet, LRp As Range, Red, Annu, i%, Nm$, Pnm$, mfm As Boolean Set wsA = Workbooks("Annuaire_APEM.xls").Worksheets("Base") wsA.Unprotect On Error GoTo 0 Set LRp = ThisWorkbook.Worksheets("Report").Range("A1").CurrentRegion.Offset(1).Resize(1) Annu = wsA.Range("A1").CurrentRegion.Resize(, 2).Value Nm = LRp.Cells(1, 1): Pnm = LRp.Cells(1, 2) Red = Array(IIf([TelF] = "x", 6, -6), IIf([TelP] = "x", 7, -7), IIf([TelB] = "x", 8, -8), _ IIf([Mem] = "Devenir", 20, -20)) For i = 2 To UBound(Annu) If Annu(i, 1) = Nm And Annu(i, 2) = Pnm Then Exit For Next i If i > UBound(Annu) Then mfm = True Application.ScreenUpdating = False With wsA.Cells(i, 1).Resize(, LRp.Columns.Count) .Value = LRp.Value If mfm Then .Offset(-1).Copy: .Cells(1, 1).PasteSpecial xlPasteFormats End If For i = 0 To UBound(Red) .Cells(1, Abs(Red(i))).Font.Color = IIf(Red(i) > 0, vbRed, vbBlack) Next i End With Exit Sub NonOuvert: MsgBox "Ouvrir le classeur Annuaire_APEM.", vbInformation, "Mise à jour Annuaire" End Sub Private Sub Btn_Traite_Click() MsgBox "La fiche a été traitée et archivée dans le dossier C:\ADD\RecepFiche." End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim tx, i% tx = Target.Value Application.EnableEvents = False Select Case Target.Address(False, False) Case "Mf" Btn_MajBase.Visible = (UCase(tx) = "V") Btn_ValiderSaisie.Visible = Not (UCase(tx) = "V") Case "A29", "A34", "A37", "S10", "S18", "S21", "S34" Target = UCase(Left(tx, 1)) & LCase(Mid(tx, 2)) Case "A4", "K7", "G24" Target = UCase(tx) Case "K4" tx = Split("-" & tx, "-") For i = 1 To UBound(tx) tx(i) = StrConv(tx(i), vbProperCase) Next i Target = Replace(Join(tx, "-"), "-", "", 1, 1) End Select Application.EnableEvents = True Range("J13").Font.Size = 14 End Sub Private Sub Btn_MajBase_Click() ' Btn_ValiderSaisie.Visible = False ' Btn_MajBase.Visible = True On Error Resume Next Workbooks("Annuaire_APEM.xls").Activate If Err <> 0 Then 'on gere l'erreur On Error Resume Next chemfich = "C:\ADD\Annuaire_APEM.xls" 'si pas ouvert on va en error Workbooks("Annuaire_APEM.xls").Activate 'on ouvre si err If Err <> 0 Then Workbooks.Open (chemfich) ActiveWorkbook.Unprotect "a" Annuaire Else: Annuaire 'MsgBox "L'annuaire_A PEM.xls est ouvert" End If ActiveWorkbook.SaveAs Filename:="C:\ADD\RecepFiche\" & Range("A4").Value & " " & Range("K4").Value & ".xls" MsgBox "La mise à jour de l'annuaire a été effectuée et" & Chr(10) _ & "la fiche archivée dans : C:\ADD\FichesTraitées\" Btn_Traite.Visible = True Call SupDosFi ThisWorkbook.Save ' Application.Quit ThisWorkbook.Activate 'ajouté End Sub Private Sub Btn_ValiderSaisie_Click() Dim chDos$, Dos$, Fich$ 'chDos = Environ("userprofile") & "\Desktop\" Dim Obj As Object Set Obj = CreateObject("WScript.Shell") chDos = Obj.SpecialFolders("Desktop") & "\" 'création dossier NouvelFiche Dos = "NouvelFiche" If Dir(chDos & Dos, vbSystem + vbDirectory + vbHidden) = "" Then MkDir chDos & Dos End If chDos = chDos & Dos & "\" Fich = Me.Range("A4") & " " & Me.Range("K4") & ".xls" ThisWorkbook.SaveCopyAs chDos & Fich Application.DisplayAlerts = False If MsgBox("Autre fiche à établir ?", vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then '--- oui, autre fiche à établir If MsgBox("Souhaitez-vous que les données affichées soient effacées ?", _ vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then EffacerFiche End If Else '--- non, pas d'autre fiche à établir chDos = Left(chDos, Len(chDos) - 1) CompresserNouvelFiche chDos, chDos & ".zip" Supdos Btn_ValiderSaisie.Visible = False Btn_MajBase.Visible = True 'EffacerFiche End If Call TransMail Application.DisplayAlerts = False ActiveWorkbook.Save Application.Quit End Sub Private Sub MFC() Range("A2").Font.ColorIndex = 2 Range("A47:Y47,J13").Font.Size = 14 [AC1] = "" End Sub Private Sub SupDosFi() Dim bureau$, Dossier$, zip$, fichier$ bureau = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" Dossier = bureau & "NouvelFiche\" ' zip = bureau & "NouvelFiche.zip" ' If Dir(zip, vbArchive) <> "" Then Kill zip If Dir(Dossier, vbDirectory) <> "" Then fichier = Dir(Dossier & "*.*") Do While fichier <> "" Kill Dossier & fichier fichier = Dir Loop RmDir Dossier End If End Sub Sub Supdos() Dim Dossier$, zip$, f 'dossier = Environ("userprofile")& "\DeskTop\NouvelFiche\" Dossier = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\NouvelFiche\" f = Dir(Dossier) Do While f <> "": Kill Dossier & "\" & f: f = Dir: Loop RmDir Dossier End Sub ThisWorkbook Private Sub Workbook_Open() Sheets("FR").Btn_ValiderSaisie.Visible = True Sheets("FR").Btn_MajBase.Visible = False Sheets("FR").Btn_Traite.Visible = False End Sub Module1 Option Explicit Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub MskDMskReport() With Worksheets("Report") If .Visible = xlSheetVisible Then .Visible = xlSheetVeryHidden Else .Visible = xlSheetVisible End If End With End Sub Sub TransMail() Dim OL As Object If StrComp(Application, "Outlook", vbTextCompare) = 0 Then Set OL = Application Else Set OL = CreateObject("outlook.application") End If Dim MESSAGE As Object Dim objRecipient As Object 'en LATEBINDING on doit déclarer les constantes Outlook utilisées Const olFormatPlain = 1 Const olFormatHTML = 2 Const olTo = 1 Const olCC = 2 Const olBCC = 3 Set MESSAGE = OL.CreateItem(0) With MESSAGE .Subject = "Mise a jour Annuaire_APEM" 'Soit on ajoute un Corps en TEXTE BRUT .BodyFormat = olFormatPlain .Body = "Dossier pour mise à jour de l'annuaire." '& vbCr & "Jean" 'Soit on ajoute un Corps en HTML '.BodyFormat = olFormatHTML '.HTMLBody = "<html><body> <font face=""arial""><p>Bonjour,</p><p>Ceci est un exemple de Message HTML</p><p>Il faut utiliser des balises HTML pour formater le texte.</p><p>En <strong>gras</strong>, <em>Italic</em>, <u>Souligné</u></p><BR><p>Je suis passé à la ligne</p><p>Voici un lien hypertexte.</p>" _ & "<a href=""mailto:Joe.User@MyCompany.com"">Joe User</a></font></body></html>" 'Ajout des destinataires zone nommée : "DestMail" Dim cellule As Range For Each cellule In Worksheets("FR").Range("DestMail") If InStr(1, cellule.Value, "@") > 0 Then Set objRecipient = .Recipients.Add(cellule.Value) objRecipient.Type = olTo 'olBCC, olCC, olOriginator ou olTo. objRecipient.Resolve End If Next 'Ajout d 'une PJ Dim MaPJ 'Nom du dossier a joindre : "NouvelFiche.zip" Dim strFolder As String, WshShell, leFichier Set WshShell = CreateObject("WScript.Shell") strFolder = WshShell.SpecialFolders("Desktop") MaPJ = "NouvelFiche.zip" 'on vérifie d'abord qu'il existe. If Dir(strFolder & "\" & MaPJ) <> "" Then .Attachments.Add (strFolder & "\" & MaPJ) Else MsgBox "Fichier : " & MaPJ & vbCr & "Non trouvée sur:" & vbCr & strFolder, vbCritical .display 'on affiche le mail et fin End End If 'ajout pour lecture ' .ReadReceiptRequested = True 'envoi selon e-mail en J13 : .SentOnBehalfOfName = Worksheets("FR").Range("J13") 'Display 'Soit je l'affiche .Send 'Soit je l'envoi End With End Sub
bonjour,
dans CompresserNouvelFiche tu as un lancement de Transmail
ainsi que dans Btn_ValiderSaisie_Click
Re
Je ne sais comment j'ai pu ne pas voir cette évidence, je suis confus et je tiens Oliv, à te remercier pour ta grande générosité de cœur, ton humilité évidente ainsi que pour l’aide efficace plus qu’appréciable et appréciée que tu m’a apportée, ainsi que de tout ce temps que tu as consacré.
Cela fait vraiment chaud au cœur de croiser des gens comme toi, cela devient tellement rare de nos jours.
Merci à ce forum super.
Re
J'ai apporté une modif ici en gras :
En te remerciant.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
2
3
4
5
6
7
8
9
10If MsgBox("Autre fiche à établir ?", vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then '--- oui, autre fiche à établir If MsgBox("Souhaitez-vous que les données affichées soient effacées ?", _ vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then EffacerFiche End If Set Feuille = ActiveSheet Feuille.Select Exit Sub Else
ps: je ne vois pas le bouton pour mettre en résolu ensuite.
Bonjour,
J'ai besoin de votre aide, je suis novice dans l'utilisation de macro VBA et j'ai besoin d'une solution.
Je cherche a rajouter une notion : Si il ne trouve pas de fichier à joindre il n'envoi pas de mail au contact où le fichier est manquant, mais qu'il envoi quand même à ceux où il trouve un fichier correspondant.
J'aimerais également rajouter une colonne où il y aurait les contacts à mettre en copie, et rajouter la donnée qui se trouve dans cette colonne dans le code CC, j'ai essayé mais je n'y suis pas parvenue.
Merci à vous.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Vous avez un bloqueur de publicités installé.
Le Club Developpez.com n'affiche que des publicités IT, discrètes et non intrusives.
Afin que nous puissions continuer à vous fournir gratuitement du contenu de qualité, merci de nous soutenir en désactivant votre bloqueur de publicités sur Developpez.com.
Répondre avec citation
Oliv'
Partager