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
| Public Sub envoi_mail(position As Long)
Dim d As Range, f As Range
Dim valtablo As Variant
Dim liste_adresses As String
Dim lobjet As String
Dim lapj1 As String, lapj2 As String
Dim full_lapj1 As String, full_lapj2 As String
Dim body_mail As String
Dim racine_pj As String
racine_pj = "R:\...\7- FINANCIER\FACTURES\FACTURES\4) FACTURES\2020\2020-08"
'Exension des fichiers adaptés
'A ADAPTER
Dim lextension As String
lextension = ".xlsm"
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
With Worksheets("Données").ListObjects("T_Ang")
'liste des destinataires
Set d = .DataBodyRange.Cells(position, .ListColumns("Mail1").Index)
Set f = .DataBodyRange.Cells(position, .ListColumns("Mail3").Index)
valtablo = Worksheets("Données").Range(d, f).Value
Set f = Nothing
Set d = Nothing
liste_adresses = Application.WorksheetFunction.TextJoin("; ", True, valtablo)
Debug.Print liste_adresses
'Objet du mail
lobjet = .ListColumns("Sujet").DataBodyRange.Cells(position, 1).Value
'Nom de la pièce jointe 1
lapj1 = .ListColumns("Facture1").DataBodyRange.Cells(position, 1).Value
lapj1 = Trim(lapj1) & lextension
'Chemin complet de la pièce jointe 1
full_lapj1 = racine_pj & Application.PathSeparator & lapj1
'Contrôle
Debug.Print full_lapj1
'Nom de la pièce jointe 2
lapj2 = .ListColumns("Facture2").DataBodyRange.Cells(position, 1).Value
lapj2 = Trim(lapj2) & lextension
'Chemin complet de la pièce jointe 1
full_lapj2 = racine_pj & Application.PathSeparator & lapj2
'Contrôle
Debug.Print full_lapj2
'Corps de texte
body_mail = .ListColumns("Formule").DataBodyRange.Cells(position, 1).Value & Chr(13) & Chr(13) & _
.ListColumns("Body").DataBodyRange.Cells(position, 1).Value
End With
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Application.ScreenUpdating = False
Dim MonItem As Outlook.MailItem
'Requiert une référence à la bibliothèque d'objets Outlook
Dim Applic_Outlook As Outlook.Application
Dim édit_ol As Outlook.Inspector
'Requiert une référence à la bibliothèque d'objets Word
'Dim wdDoc As Word.Document
'Crée l'objet Outlook
Set Applic_Outlook = Outlook.Application
'Créer l'élément de mail et le transmettre
Set MonItem = Applic_Outlook.CreateItem(olMailItem)
With MonItem
.to = liste_adresses
.Subject = lobjet
.Body = body_mail
'.BodyFormat = olFormatHTML
.Display
If ExisteFichier(full_lapj1) = True Then
.Attachments.Add Source:=full_lapj1
Else
MsgBox _
Prompt:="Fichier 1 inexistant " & Chr(13) & full_lapj1, _
Buttons:=vbCritical, _
Title:="Pièce jointe 1 erronée."
End
End If
If Replace(lapj2, lextension, "") <> "" Then
If ExisteFichier(full_lapj2) = True Then
.Attachments.Add Source:=full_lapj2
Else
MsgBox _
Prompt:="Fichier 2 inexistant " & Chr(23) & full_lapj2, _
Buttons:=vbCritical, _
Title:="Pièce jointe 2 erronée."
End
End If
End If
.Send
End With
Set MonItem = Nothing
Set Applic_Outlook = Nothing
End Sub |
