Navigation

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

  1. #1
    Expert éminent
    Gestion de tableaux structurés pour envois instantanés de mails différenciés.
    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.

    Bien Cordialement.

    Marcel

    Dernier billet:
    Suppression des doublons d'un tableau structuré, gestion d'un array

    Pas de messagerie personnelle pour vos questions, s'il vous plaît. La réponse peut servir aux autres membres. Merci.


  2. #2
    Membre expérimenté
    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,
    Michaël

    Si mon aide/avis vous a été profitable , n'hésitez pas à cliquer sur , ça fait toujours plaisir...
    _________________________________________________________________________________________________________________

    "Tout le monde est un génie. Mais si on juge un poisson sur sa capacité à grimper à un arbre, il passera sa vie à croire qu'il est stupide..."
    Albert Einstein

  3. #3
    Expert éminent
    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 & ")))")

    Bien Cordialement.

    Marcel

    Dernier billet:
    Suppression des doublons d'un tableau structuré, gestion d'un array

    Pas de messagerie personnelle pour vos questions, s'il vous plaît. La réponse peut servir aux autres membres. Merci.


###raw>template_hook.ano_emploi###