MarcelG

CE BILLLET A FAIT L'OBJET D'UNE MISE A JOUR DANS CETTE CONTRIBUTION

Bonjour à tous,

Sur une même base de données, des états peuvent être différents s’ils sont destinés à des interlocuteurs différents.
(Somme des appellations pour un Directeur Marketing, Somme des chiffres d’affaires d’une aire de chalandise pour un Directeur Régional, etc….)

Ces derniers seront ainsi destinataires de courriels ayant
- Des destinataires différents
- Des objets différents
- Des pièces jointes différentes
- Des corps de texte différents

A chaque fois, c’est la même base de données qui est traitée à des échéances variables (jour, mois, semaine). Cette échéance est susceptible, d'ailleurs, de modifier la pièce jointe et donc son nom.

Le présent billet a pour sujet la diffusion d’un bloc de tous ces éléments Outlook générée par une seule procédure.

Architecture du projet:

Une cellule désignera une liste (exemple liste1).

A celle-ci est associée un objet de mail, une pièce jointe, un détail de destinataires qui la composent et un corps de texte.
Les noms de plage affectées à ces éléments comprennent cette valeur de cellule
Ainsi, à la valeur de cellule liste1 correspondront les plages nommées détail_liste1 (liste des destinataires) et corps_liste1 (corps de texte).



Ainsi, pour la valeur de cellule liste1, 2 destinataires (mercatog et Marcel) recevront un mail avec
- Pour pièce jointe, le document Pdf « Menu »
- Pour objet, « Le menu du jour »
- Pour corps de mail, la partie du document sur fond jaune, image de Venise comprise

Même cas de figure pour la valeur de cellule liste2

Bien entendu, la rigueur au niveau des noms de plage est nécessaire. Comme toujours.

Aussi, par mesure de souplesse, cette cellule sera-t-elle « typée » par ses différents composants.
Partant, une fonction peut dès lors être envisagée pour le report de ceux-ci.

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
Option Explicit

Dim fullname_img As String

Public Type destinataire
        obj As String
        lapj As String
        lalistedest As Range
        lecorps As Range
End Type

Public Function données_dest(ledest As String) As destinataire

Dim lawks As Worksheet
Set lawks = ThisWorkbook.Worksheets("liste_mails")

Dim t As Range

Set t = lawks.Range("liste_dest").Find(what:=ledest, lookat:=xlWhole, LookIn:=xlValues)

With données_dest
        Set .lalistedest = lawks.Range("Détail_" & CStr(t.Value))
        .obj = t.Offset(0, 1).Value
        .lapj = t.Offset(0, 2).Value
        Set .lecorps = lawks.Range("corps_" & t.Value)
End With

Set t = Nothing

Set lawks = Nothing

End Function

Le corps de texte Excel (qui peut contenir comme ici une image) sera enregistré en tant qu’image.
Celle-ci sera importée dans le mail au moment de l’envoi.
Ce processus évite la gestion, parfois fastidieuse, d’un corps de texte dans Outlook.

L’activation de 3 références est nécessaire
- Microsoft Scripting Run Time (pour la gestion des images enregistrées)
- Library Outlook (pour la gestion de l’item)
- Library Word (pour la gestion de du corps de texte)

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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
Public Sub envoi_mails_groupés()

Dim c As Range

For Each c In Worksheets("liste_mails").Range("liste_dest")

        Call Envoi_Mail(c.Value)

Next c

Application.DisplayAlerts = True

End Sub

Sub Envoi_Mail(letoto As String)

 Dim lobjet As String
 Dim str_pj As String
 Dim rng_dest As Range
 Dim rng_body As Range
 
With données_dest(letoto)
        lobjet = .obj
        str_pj = .lapj
        Set rng_dest = .lalistedest
        Set rng_body = .lecorps
End With

Dim lapj As String
lapj = ThisWorkbook.Path & Application.PathSeparator & str_pj & ".pdf"

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

Dim liste_adresses As String

liste_adresses = ""
'For Each c In données_dest(letoto).lalistedest
'        liste_adresses = liste_adresses & c.Value & ";"
'Next c
Dim tb() As Variant
ReDim tb(1 To rng_dest.Count)
tb = Application.Transpose(rng_dest)

liste_adresses = Join(tb, ";")

Application.ScreenUpdating = False

'Crée l'objet Outlook
Set Applic_Outlook = CreateObject("Outlook.Application")

'Créer l'élément de mail et le transmettre
Set MonItem = Applic_Outlook.CreateItem(olMailItem)

With MonItem
        
        '.BodyFormat = olFormatHTML
        .To = liste_adresses
        .Subject = lobjet
        .Display
        .Attachments.Add Source:=lapj

        On Error Resume Next
        AppActivate lobjet & " - Message (HTML)" ' Active Outlook
        AppActivate lobjet & " - Message" ' Active Outlook
        On Error GoTo 0
        
        Set édit_ol = .GetInspector
        
        'Portée module
        Set wdDoc = édit_ol.WordEditor
        
        'importation du corps de texte dans le corps de message
        Call save_img(données_dest(letoto).lecorps)

        With wdDoc
                'New 10 Décembre 2019
                .InlineShapes.AddPicture Filename:=fullname_img
                'Image redimensionnée
                .InlineShapes(1).Width = 600
        End With

        Set wdDoc = Nothing
        Set édit_ol = Nothing

        .Send
        
        Application.CutCopyMode = False
        
End With

Set MonItem = Nothing
Set Applic_Outlook = Nothing

Set rng_dest = Nothing
Set rng_body = Nothing

ActiveWindow.DisplayGridlines = True

End Sub

Public Sub save_img(corpstexte As Range)

'Création d'un fichier image sur le répertoire de ce classeur

'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Dim s As Shape
With Worksheets("liste_mails")
        
        .Activate
        
        ActiveWindow.DisplayGridlines = False
        
        'Précaution
        If .Shapes.Count > 0 Then
                For Each s In .Shapes
                        With s
                                If (InStr(.Name, "Venise") + InStr(.Name, "Rome")) = 0 Then .Delete
                        End With
                Next s
        End If
        
End With

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Dim texte_date As String, name_img As String

texte_date = Format(Date, "yyyymmdd")
name_img = "Image_" & texte_date & ".jpg"
fullname_img = ThisWorkbook.Path & "\" & name_img

'----------------------
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.file
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(ThisWorkbook.Path)
 
For Each FileItem In SourceFolder.Files
 
        With FileItem
               'Debug.Print .Name
               If InStr(.Name, "jpg") > 0 Then
                     If InStr(.Name, name_img) = 0 Then Kill .Path
               End If
        End With
 
Next FileItem

Set SourceFolder = Nothing
Set Fso = Nothing
 
'----------------------

Application.ScreenUpdating = False

'Dim lechart As Object, hPicAvail As Long
Dim lechart As Object

With Worksheets("liste_mails")

    
    Set lechart = .ChartObjects.Add(0, 0, 1, 1).Chart
    
         CreateObject("htmlfile").parentwindow.clipboardData.clearData ("Text")  'on vide le clipboard entre chaque copie pour tester vraiment le available
        
        With lechart.Parent
                 
                 .Width = corpstexte.Width
                 .Height = corpstexte.Height
                 .Left = corpstexte.Left + corpstexte.Width + 20:
                 
                 corpstexte.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                 
                 .Select
                 
                 Do
                       DoEvents
                 Loop Until .Chart.Pictures.Count = 0
                 
                 .Chart.Paste
                 
                 'Do
                 '      DoEvents
                 'Loop While .Chart.Pictures.Count = 0
                 
                 With .Chart
                       .Export Filename:=fullname_img, FilterName:="jpg"
                 End With
                 
                 .Delete
                 
           End With
           
      Set lechart = Nothing
      
End With

End Sub

A noter, en ce qui concerne les destinataires, plutôt que boucler sur une suite de valeurs pour constituer, par concaténation, une chaîne de caractères, je préfère lier les éléments d'une variable tableau par le séparateur ";".
Ceci par la fonction "Join".

Par la simple activation d'un bouton de commande, la procédure "envoi_mails_groupés" procèdera à l'adresse des 2 mails.

2 développements annexes à toute fin utile

1 - Suppression signature par défaut (peut être pratique si celle-ci fait partie du corps de texte dans le cas, par exemple, d’expéditeurs différents

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
Sub TestDeleteSig()
    Dim objMsg As Outlook.MailItem
    Set objMsg = Application.CreateItem(olMailItem)
    objMsg.Display
    Call DeleteSig(objMsg)
    Set objMsg = Nothing
End Sub

Sub DeleteSig(msg As Outlook.MailItem)
    Dim objDoc As Word.Document
    Dim objBkm As Word.Bookmark
    On Error Resume Next
    Set objDoc = msg.GetInspector.WordEditor
    Set objBkm = objDoc.Bookmarks("_MailAutoSig")
    If Not objBkm Is Nothing Then
        objBkm.Select
        objDoc.Windows(1).Selection.Delete
    End If
    Set objDoc = Nothing
    Set objBkm = Nothing
End Sub

Des variantes existent à ce sujet.
Notamment, avec ma préférence car il n'y a pas obligation de sélectionner l'objet

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Dim objBkm As Word.Bookmark
 
           With wdDoc
                    If .bookmarks.Exists(Name:="_MailAutoSig") Then _
                                .bookmarks(Index:="_MailAutoSig").Range.Delete
            End With

ou bien

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
    Set objBkm = wdDoc.bookmarks("_MailAutoSig")
    If Not objBkm Is Nothing Then objBkm.Range.Delete
    Set objBkm = Nothing

Ce dernier code est sans doute adaptable à d'autres objets, comme une feuille de travail par exemple.

2 - Gestion d’Outlook (ouverture si fermé, fermeture puis ouverture afin d’obtenir une session propre)

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
Option Explicit
 
 Public Declare Function SetWindowPos _
        Lib "user32" ( _
            ByVal Hwnd As Long, _
            ByVal hWndInsertAfter As Long, _
            ByVal x As Long, ByVal y As Long, _
            ByVal cx As Long, ByVal cy As Long, _
            ByVal wFlags As Long) _
    As Long

Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2

Sub Test_Open_Outlook()

Dim Chemin As String
Chemin = "C:\Program Files (x86)\Microsoft Office\root\Office16\OUTLOOK.exe"
 
Dim Appli As Object
Dim session_Outlook As New Outlook.Application
Dim Ole_appli As Object
 
Dim typouv As Byte
typouv = 1

On Error Resume Next
Set Appli = GetObject(, "Outlook.Application")
 
Call ShowXLOnTop(True)

If Appli Is Nothing Then

      'Ouvre Outlook
        session_Outlook = Shell(Chemin, typouv)

Else
        
        'Fermeture de l'application Outlook si ouverte et réouverture d'une nouvelle
        Call KillProcess("Outlook.exe")
        
        session_Outlook = Shell(Chemin, typouv)

End If
 
Set Ole_appli = Nothing
Set Appli = Nothing

Call ShowXLOnTop(False)

End Sub

Sub ShowXLOnTop(ByVal OnTop As Boolean)
    Dim xStype As Long

Dim xHwnd As Long

If OnTop Then
        xStype = HWND_TOPMOST
    Else
        xStype = HWND_NOTOPMOST
    End If
    Call SetWindowPos(Application.Hwnd, xStype, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
End Sub

 Public Function KillProcess(ByVal ProcessName As String) As Boolean
    Dim svc As Object
    Dim sQuery As String
    Dim oproc
    Set svc = GetObject("winmgmts:root\cimv2")
    sQuery = "select * from win32_process where name='" & ProcessName & "'"
    For Each oproc In svc.execquery(sQuery)
        oproc.Terminate
    Next
    Set svc = Nothing
End Function