Discussion :

[MarcelG]

Bonjour à tous,

Je reprends mon précédent billet en l’adaptant aux tableaux structurés.
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, mappée par un tableau structuré, 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:

Dans une feuille « liste_mails », un tableau structuré « T_Mails » comporte les différents éléments de chaque courriel (destinataire, objet, nom de la pièce jointe ici supposé sous forme PDF).

T_Mails



A noter la formulation, à n'entrer qu'une seule fois (copie, croix tirée vers le bas = OUT)

="Menu de la "&[@destinataires] & " à la date du " &TEXTE(AUJOURDHUI();"j mmmm aaaa")

A chaque item de la colonne « destinataires » est associé, sur une autre feuille « Utilitaires », un tableau structuré, à une colonne, dont le nom est la concaténation « T_ » & item



Noms de destinataires parfaitement aléatoires. Toute allusion à des personnes existantes seraient le pur fruit du hasard.

Cette structure permet la complétude de chaque tableau de manière aisée (End(xlUp) = Out, NamesAdd =Out)
Vous remarquerez par ailleurs que l’unique colonne de chaque tableau est dénommée uniformément « détail_liste » (important pour la suite)

Enfin le corps de texte est associé, par son nom de plage, à chaque item destinataire



Ainsi, les destinataires désignés dans T_liste1 recevront un courriel avec
- Pour pièce jointe, le document Pdf « Menu de la liste.....»
- Pour objet, « Le menu du jour »
- Pour corps de mail, la partie du document sur fond jaune, image de Venise comprise

Le nom de chaque élément est défini en fonction du destinataire
liste1 – T_liste_1 (nom du tableau structuré) – corps_liste1 (nom de la plage, image comprise)
Même cas de figure pour T_liste2

En termes de développement VBA

Par mesure de souplesse, l’item destinataire fera l’objet d’une variable « 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
Option Explicit
 
Dim fullname_img As String
 
Public Type destinataire
        obj_mail As String
        lapj As String
        lalistedest As Range
        lecorps As Range
End Type
 
Public Function données_dest(ledest As String) As destinataire
 
Dim position As Long
 
position = Evaluate("=MATCH(""" & ledest & """,T_Mails[destinataires],0)")
 
With données_dest
 
        .obj_mail = Worksheets("liste_mails").Range("T_Mails[objet]").Cells(position, 1).Value
 
        .lapj = Worksheets("liste_mails").Range("T_Mails[pièce_jointe]").Cells(position, 1).Value
 
        Set .lalistedest = Worksheets("Utilitaires").Range("T_" & ledest & "[détail_liste]")
 
        Set .lecorps = Worksheets("Utilitaires").Range("corps_" & ledest)
 
End With
 
End Function

A noter, le nombre de double-quottes pour la fonction Equiv (Match en VBA).

Remarque:

Je préfère la notation

Code :

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

Range("T_Mails[objet]").Cells(position, 1)

A celle

Code :

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

Range("T_Mails[objet]")(position)

Plus claire selon moi. Bien entendu, les 2 notations restent valables.

L’exécution de 2 procédures annexes est optionnel
- « Test_Open_Outlook » : ferme Outlook si ouvert puis ouverture « propre »
- « efface_signature », comme son nom l’indique

Procédure de lancement

Code :

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

1
2
3
Public Sub global_mails()
Call envoi_mails_groupés(vérif_outlook:=True, noconserv_signature:=True)
End Sub

Exécution:
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. (Je n'y procède, pour ma part, jamais)

L’activation de 3 références est nécessaire (EarlyBinding, notion relativement acquise, j’essaie de la caser )
- 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
Public Sub envoi_mails_groupés(vérif_outlook As Boolean, noconserv_signature As Boolean)
 
If vérif_outlook = True Then _
        Call Test_Open_Outlook
 
Dim c As Range
 
For Each c In Worksheets("liste_mails").Range("T_Mails[destinataires]")
 
         Call Envoi_Mail(ledestinataire:=c.Value, suppression_signature:=noconserv_signature)
 
Next c
 
End Sub
 
Sub Envoi_Mail(ledestinataire As String, suppression_signature As Boolean)
 
 Dim lobjet As String
 Dim str_pj As String
 Dim rng_dest As Object
 Dim rng_body As Range
 
With données_dest(ledestinataire)
        lobjet = .obj_mail
        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 = Outlook.Application
 
'Créer l'élément de mail et le transmettre
Set MonItem = Applic_Outlook.CreateItem(olMailItem)
 
'\Exports_Fiches_202002\CA_DCR_53 cumulé du mois au 24 Février 2020.pdf
 
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(ledestinataire).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
 
        If suppression_signature = True Then _
                Call efface_signature(MonItem)
 
        .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

Image sauvegardée pour être incluse dans le 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
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

Procédure d'effacement de la signature (Plusieurs variantes existent)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub efface_signature(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

La procédure qui consiste à fermer Outlook si ouvert puis à ouvrir un "Outlook tout neuf"
Parfois, dans mon environnement professionnel, cette procédure a été obligatoire

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

Un fichier exemple est joint à ce billet.
Les éléments de feuilles (noms, pièces jointes…) ainsi que le code (emplacement des pièces jointes…) restent, bien entendu, à adapter.

Par avance, merci pour vos remarques.

Bonne fin de journée à tous.

[mfoxy]

Salut Marcel,

Good Job, je testerai la chose dès que j'aurais un peu de temps devant moi.
(Je me réserve le domaine mais en .Be comme Pierre et Philippe &#128540

Bat,

[MarcelG]

Bonsoir Michaël, Bonsoir le Forum,

Une modification dans la déclaration de la variable rng_dest

Code :

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

1
2
3
4
5
Sub Envoi_Mail(ledestinataire As String, suppression_signature As Boolean)

 Dim lobjet As String
 Dim str_pj As String
 Dim rng_dest As Range

D'autre part.

Je viens de consulter ce billet de Pierre, que je salue au passage.

Les 4 lignes

Code :

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

1
2
3
4
5
Dim tb() As Variant
ReDim tb(1 To rng_dest.Count)
tb = Application.Transpose(rng_dest)
 
liste_adresses = Join(tb, ";")

sont remplacées par une seule

Code :

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

liste_adresses = Application.WorksheetFunction.TextJoin(";", True, rng_dest)

ou bien si l'on veut compléter par les fonctions TRIER et UNIQUE

Code :

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

liste_adresses = Evaluate("=TEXTJOIN("";"",TRUE,SORT(UNIQUE(" & rng_dest.Address & ")))")