Discussion :

[SOM.Ware]

bonjour a tous,

avec une macro VBA Outlook je souhaite envoyer en un seul clic les brouillons de mails sélectionnés dans le répertoire des brouillons. C'est à cet endroit que notre GPAO dépose les documents à envoyer par mail.

a l'exécution de la macro la méthode .Send renvoie le message suivant : Erreur d'execution -2147467259 (80004005) Cette methode ne peut pas être utilisée avec un élément de message réponse inclus.


voici le code :

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
'------------Macro -- SOM pour Outlook ----------- V2025.1.01 JMD LE 2025-01-28
'
'
Public VarSignature As String
Public VerMacro As String
Public NomMacro As String
 
Public Sub InitVar()
VerMacro = "    SOM.ware  V2025.1.01"
NomMacro = "Envoi des Mails Brouillons"
VarSignature = "jmd-2025.htm" 'Nom de la signature à utiliser mettre toutes les lettres en minuscules
End Sub
Public Function UserSignatures(NomFichierSignature As String) As String
Dim oFso As Object          'Scripting.FileSystemObject
Dim oCurFile As Object      'Scripting.File
Dim oRegExp As Object       'VBScript_RegExp_55.regExp
Dim oMatches As Object      'VBScript_RegExp_55.MatchCollection
Dim oMatch As Object        'VBScript_RegExp_55.Match
Dim pathSignatures As String
Dim relativePath As String
Dim absolutePath As String
Dim htmlSignature As String
 
    'initialisation
    'Set UserSignatures = New Collection
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Set oRegExp = CreateObject("vbscript.regexp")
    With oRegExp
        .Pattern = "<[^>]+src=""([^"">]+)"""
        .MultiLine = True
        .Global = True
    End With
 
    'boucler sur tous les fichiers du dossier %APPDATA%\Roaming\Microsoft\Signatures
    pathSignatures = Environ("APPDATA") & "\Microsoft\Signatures"
    For Each oCurFile In oFso.GetFolder(pathSignatures).Files
        'si le fichier est NomFichierSignature (signature.htm)
        If LCase(oCurFile.Name) = NomFichierSignature Then
            'récupérer le contenu html
            htmlSignature = oFso.OpenTextFile(oCurFile.Path, 1).ReadAll
            'remplacer les path relatifs en path absolus
            Set oMatches = oRegExp.Execute(htmlSignature)
            For Each oMatch In oMatches
                relativePath = oMatch.SubMatches(0)
                absolutePath = oFso.BuildPath(pathSignatures, relativePath)
                If oFso.FileExists(absolutePath) Then
                    htmlSignature = Replace(htmlSignature, "src=""" & relativePath & """", "src=""" & absolutePath & """")
                End If
            Next oMatch
            'affecter la signature à la function
            UserSignatures = htmlSignature
        End If
    Next oCurFile
 
    Set oFso = Nothing
    Set oCurFile = Nothing
    Set oRegExp = Nothing
    Set oMatches = Nothing
    Set oMatch = Nothing
 
End Function
Sub Envoi_Mails_CLIPPER()
Dim xSelection As Selection
Dim xPromptStr As String
Dim MySignature As String
Dim xYesOrNo As Integer
Dim i As Long
Dim xAccount As Account
Dim xCurFld As Folder
Dim xDraftsFld As Folder
Dim xTmpFld As Folder
Dim xArr() As String
Dim xCount As Integer
Dim xMail As Object
 
'On Error Resume Next
 
InitVar
xCount = 0: MySignature = ""
 
Set xTmpFld = Nothing
Set xCurFld = Application.ActiveExplorer.CurrentFolder
For Each xAccount In Outlook.Application.Session.Accounts
    Set xDraftsFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
    If xDraftsFld.EntryID = xCurFld.EntryID Then
        Set xTmpFld = xCurFld.Parent
    End If
Next xAccount
If xTmpFld Is Nothing Then
    MsgBox "Le dossier courant n'est pas le dossier Brouillons", vbInformation, NomMacro & " " & VerMacro
    Exit Sub
End If
 
MySignature = UserSignatures(VarSignature)
 
Set xSelection = Outlook.Application.ActiveExplorer.Selection
 
If xSelection.Count > 0 Then
    xPromptStr = xSelection.Count & " Brouillon(s) sélectionné(s), voulez-vous proceder à l'envoi ?"
    xYesOrNo = MsgBox(xPromptStr, vbQuestion + vbYesNo, NomMacro & " " & VerMacro)
    If xYesOrNo = vbYes Then
        ReDim xArr(xSelection.Count - 1)
        For i = 1 To xSelection.Count
            xArr(i - 1) = xSelection.Item(i).EntryID
        Next i
 
        Set Application.ActiveExplorer.CurrentFolder = xTmpFld
 
        For i = 0 To UBound(xArr)
 
           Set xMail = Application.Session.GetItemFromID(xArr(i))
 
            If xMail.Recipients.Count <> 0 Then
 
            xMail.Display (False)
            'ajout de la signature de l'utilisateur don le nom est dans VarSignature
            xMail.HTMLBody = xMail.HTMLBody & "***-" & i & "-***" & MySignature
            'envoi du mail
            xMail.Send '-*-*-* C'EST ICI QUE L'ERREUR APPARAIT *-*-*-*-
            'compteur de(s) mail(s) envoyé(s)
            'xMail.Close ' voir si nécessaire !
            xCount = xCount + 1
 
            End If
 
 
        Next i
 
        Set Application.ActiveExplorer.CurrentFolder = xCurFld
        MsgBox xCount & " message(s) envoyé(s)", vbInformation, NomMacro & " " & VerMacro
    End If
Else
    MsgBox "Pas d'objets selectionnés !", vbInformation, NomMacro & " " & VerMacro
End If
 
'Libération des variables
Set xMail = Nothing
MySignature = ""
InitVar
End Sub

Il y a surement une coquille quelque part, merci pour vos retours.

[Nain porte koi]

Hello,

j'ai trouvé ça, mais je ne suis pas sûr du tout que ça s'applique à 2019
https://support.microsoft.com/fr-fr/...4-761b3a427319
De toute façon, voyez si une mise à jour n'est pas en attente ou au contraire si une mise à jour récente ne serait pas à l'origine du pb.