Insertion de signature Outlook à la création d'un email par VBA

**lololebricoleur** · 15/04/2025, 14h34

Bonjour,

Dans ma base ACCESS, je génère des emails qu'ensuite j'envoie par le biais d'Outlook.
J'ai 10 utilisateurs sur cette base et j'aimerais qu'à la génération de l'email, la signature outlook soit insérée dans l'email mais ça ne marche pas.
Ça fonctionnait quand on était encore en office 2010 mais depuis qu'on est passé en office 2019, ça ne marche plus et je galère à trouver pourquoi.

Exemple de code principal pour générer un email :

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
 
Private Sub B_Envoyer_Click()
On Error GoTo Erreur
 
    'Déclaration des variables
    Dim MonOutlook As New Outlook.Application
    Dim MonMessage As Outlook.MailItem
    Dim MyAttachments As Outlook.Attachments
    Dim Msg As String
    Dim MsgAuto As String
    Dim IntroLibre As String
    Dim IntroAuto As String
    Dim Signature As String
    Dim StrSign As String
    Dim Con As ADODB.Connection
    Dim Jeu_Enr As ADODB.Recordset
    Dim Jeu_Enr_ses As ADODB.Recordset
    Dim Txt As String
 
    'Vérification du mode test
    If Table_INF = "" Then Table_INF = "INFormation_Locale"
    If Chemin = "" Then Chemin = "C:\Export\"
 
    If Me.SES_Num > 0 Then
        Me.SES_STA = DLookup("SES_Stage", "SESsions", "SES_Num =" & Me.S_Session)
        Me.FOR_Num = DLookup("STA_FOR", "STAge", "STA_Num =" & Me.SES_STA)
    End If
 
    'Initialisation des objets
    Set MonMessage = MonOutlook.CreateItem(0)
    Set MyAttachments = MonMessage.Attachments
    Set Con = CurrentProject.Connection
    Set Jeu_Enr = New ADODB.Recordset
    Set Jeu_Enr_ses = New ADODB.Recordset
 
    'Signature
    If UTI_Signature <> "" Then
        'MsgBox Environ("appdata")
 
        Select Case DLookup("UTI_Os", "UTIlisateur", "UTI_Num=" & Uti)
            Case 1 'Windows 7
                StrSign = Environ("appdata") & "\Microsoft\Signatures\" & UTI_Signature
            Case 2 'Windows 8
                StrSign = Environ("appdata") & "\Microsoft\Signatures\" & UTI_Signature
            Case 3 'Winbdows 10
                StrSign = Environ("appdata") & "\Microsoft\Signatures\" & UTI_Signature
            Case Else
                StrSign = ""
        End Select
 
        If Dir(StrSign) <> "" Then
            Signature = LireSignature(StrSign)
        Else
            Signature = ""
        End If
    Else
        Signature = ""
    End If
 
    'Gestion des pièces jointes
    If Me.S_Bulletin_PDF = -1 And SES > 0 Then
        DoCmd.OutputTo acOutputReport, "E_Doc_Envoi_Info_Bi", acFormatPDF, Chemin & "Bulletin d'inscription.pdf"
        MyAttachments.Add Chemin & "Bulletin d'inscription.pdf"
    End If
 
    If Me.S_Programme_PDF = -1 And SES > 0 Then
        Num_Formation = Me.FOR_Num
        Num_Session = Me.S_Session
 
        If Num_Session > 0 Then
            DoCmd.OutputTo acOutputReport, "E_Doc_Programme_Stage_OPQF", acFormatPDF, Chemin & "Programme de formation.pdf"
        Else
            DoCmd.OutputTo acOutputReport, "E_Doc_Programme_Formation_OPQF", acFormatPDF, Chemin & "Programme de formation.pdf"
        End If
 
        MyAttachments.Add Chemin & "Programme de formation.pdf"
    End If
 
    SQl = "SELECT " & Table_INF & ".INF_Chemin, " & Table_INF & ".INF_Select, " & Table_INF & ".INF_Désignation" & _
    " From " & Table_INF & _
    " WHERE (((" & Table_INF & ".INF_Select)=True));"
 
    'Jeu_Enr.Open SQl, Con, adOpenForwardOnly, adLockReadOnly
 
    SQl = "SELECT SESsions.*, REPertoire.*, STAge.*" & _
    " FROM STAge RIGHT JOIN (SESsions LEFT JOIN REPertoire ON SESsions.SES_Lieu = REPertoire.REP_Num) ON STAge.STA_Num = SESsions.SES_Stage" & _
    " WHERE (((SESsions.SES_Num)=" & Me.S_Session & "));"
    '" WHERE (((SESsions.SES_Num)=" & Me.SES_Num & "));"
 
    Jeu_Enr_ses.Open SQl, Con, adOpenForwardOnly, adLockReadOnly
 
 
 
 
    'Création du message
    IntroAuto = "<FONT size='2'><FONT face='tahoma'>Bonjour,<br/><br/>Comme convenu, veuillez trouver ci-joints les documents et les informations relatifs à la formation : " & DLookup("STA_Titre", "STAge", "STA_Num =" & Me.SES_STA) & "."
    IntroLibre = "Bonjour,"
 
    Do While Not Jeu_Enr_ses.EOF
        MsgAuto = MsgAuto & "<br/>   - Durée : " & Jeu_Enr_ses!STA_Duree_j & " jour(s)"
        MsgAuto = MsgAuto & "<br/>   - Lieu : " & Jeu_Enr_ses!REP_Ville
        If (Jeu_Enr_ses!STA_Duree_j > 1) Then
            MsgAuto = MsgAuto & "<br/>   - Dates : Du " & Jeu_Enr_ses!SES_DD & " au " & Jeu_Enr_ses!SES_DF
        Else
            MsgAuto = MsgAuto & "<br/>   - Date : Le " & Jeu_Enr_ses!SES_DD
        End If
 
        Jeu_Enr_ses.MoveNext
    Loop
 
    If Me.S_Lien_Programme = -1 Then MsgAuto = MsgAuto & "<br/><br/> Vous pouvez également consulter le programme et vous inscrire directement sur notre nouveau site Internet en cliquant sur les liens ci-dessous  : <br/>   - Pour consulter le programme de la formation : " & "<a href=https://anofab.fr/" & Me.SES_STA & " >Cliquez ici</a><br/>"
    If Me.S_Lien_Inscription = -1 Then MsgAuto = MsgAuto & "   - Pour vous inscrire par Internet : <a href=http://www.anofab.fr/formation/stage/" & Me.SES_STA & "/" & Me.S_Session & ">Cliquez ici</a>"
    'If Me.S_Lien_Inscription = -1 Then MsgAuto = MsgAuto & "   - Pour vous inscrire par Internet : <a href=http://www.anofab.fr/formation/stage/" & Me.SES_STA & "/" & Me.SES_Num & ">Cliquez ici</a>"
 
    Select Case Me.S_Type_Message
        Case 1 'Message automatique
        Msg = IntroAuto & MsgAuto
 
        Case 2 'Message libre
        Msg = Me.SAI_Message
 
        Case 3 'Message automatique + message libre
        Msg = IntroAuto & MsgAuto & Me.SAI_Message
 
        Case 4 'Message libre + message automatique
        Msg = Me.SAI_Message & MsgAuto
 
        Case Else: Exit Sub
    End Select
 
 
    Msg = Msg & "<br/><br/>Je reste à votre disposition pour toute information complémentaire, n'hésitez pas à me contacter.<br/><br/>Bien cordialement,"
 
    With MonMessage
        .To = Me.Mail_Destinataire   'Me.s_desMe.Destinataire 'destinataire
        .Subject = Me.Objet 'objet
        .HTMLBody = Msg & "<br/>" & Signature
        .Display
    End With
 
    'Déselection des documents
    SQl = "UPDATE " & Table_INF & " SET " & Table_INF & ".INF_Select = False" & _
    " WHERE (((" & Table_INF & ".INF_Select)=True));"
 
    DoCmd.SetWarnings False 'désactive les messages d'info auto
    DoCmd.RunSQL SQl
    DoCmd.SetWarnings True 'active les messages d'info auto
 
    'désallocation des objets
    'Jeu_Enr.Close
    Set MonOutlook = Nothing
    Set Con = Nothing
 
    SES = 0
    DoCmd.Close acForm, "F_Envoi_Info"
 
Fermer:
    Exit Sub
 
Erreur:
    MsgBox Err.Description
    Resume Fermer
 
End Sub

et dans ce code, j’appelle ce code pour récupérer la signature :

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
 
Public Function LireSignature(ByVal sFile As String) As String
On Error GoTo Erreur
 
    Dim FSO As Scripting.FileSystemObject
    Dim Fichier As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fichier = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
    LireSignature = Fichier.ReadAll
    Fichier.Close
 
Sortir:
    Exit Function
 
Erreur:
    MsgBox Err.Description
    Resume Sortir
 
End Function

Le fichier HTML de la signature est bien trouvé mais l'insertion dans le message du mail ne se fait pas

Merci de votre aide

**tee_grandbois** · 15/04/2025, 18h50

bonsoir,
j'ai eu le même problème, j'ai mis directement le nom du fichier signature:

Code :

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

1
2
3
4
5
6
   With MonMessage
        .To = Me.Mail_Destinataire   'Me.s_desMe.Destinataire 'destinataire
        .Subject = Me.Objet 'objet
        .HTMLBody = Msg & "<br/>" & StrSign
        .Display
    End With

Visiblement la fonction LireSignature ne semble plus utile (du moins pour les fichiers du type .jpg dans mon cas)

Insertion de signature Outlook à la création d'un email par VBA

VBA Access

Discussions similaires

Partager

Partager