Bonjour,

Étant débutant dans l'utilisation du VBA après m'être exercé seul, je fais appel à vous.

Le service dans lequel je travaille à besoin d'envoyer un mail avec certaines pièces jointes, j'ai donc créer un module permettant l'envoi d'un mail en fonction des informations
saisies dans certaines cellules. J'ai réussi à réaliser une procédure qui récolte ces infos et envoie mail.

Ma dernière problématique est d'enregistrer ce mail dans un dossier spécifique après l'envoi du mail. Pour l'instant je ne peux que sauvegarder le mail avant l'envoi en .msg mais à l'ouverture du fichier outlook m'ouvre l'edition du mail avec les informations déjà saisies.

Je n'arrive pas à comprendre les différentes indications trouvées sur internet via l'utilisation de l'évenement ItemSend, NameSpace, etc...

En espérant que l'un de vous puisse m'aider.

Je vous joins mon code VBA pour plus de clareté.

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
 
 
Public Sub EnvoiMail()
    If Len(Range("I3").Value) = 0 Then
        MsgBox "Renseignez l'adresse mail du destinataire"
        Exit Sub
    End If
 
    'Déclaration des variables
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
 
    Dim Tbl() As String
    Dim I As Integer
    Dim Chemin As String
 
    'Initialisation des variables
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
 
    xMailBody = "Dear colleague," & vbNewLine & vbNewLine & _
              "Please find attached the technical documents relative to the here-above mentioned order." & vbNewLine & vbNewLine & _
              "Wishing you a good receipt," & vbNewLine & vbNewLine & _
              "Best regards,"
 
    'Récupération des inputs
    On Error Resume Next
    With xOutMail
        .To = Range("I3").Value
        .CC = ""
        .BCC = ""
        .Subject = CStr(Range("B3").Value) + " - TECHNICAL DOCUMENTS"
        .Body = xMailBody
        Arc = CStr(Range("B3").Value)
 
        TblD = EnumDoss() 'Récupération des sous-dossiers sélectionnés
 
        If Not (Not TblD) Then
 
            For P = 1 To UBound(TblD) 'Traitement récursif des sous-dossiers
                TypeDoc = TblD(P)
                Chemin = "O:\" + Arc + "\Technique\" + TypeDoc
                Tbl = EnumFichiers(Chemin) 'Récupation récursive des types de fichiers souhaités
 
                If Not (Not Tbl) Then
 
                    For I = 1 To UBound(Tbl) 'Ajout des pièces jointes souhaitées
 
                        If Cells(I + 9, 7) = "O" Then
                            .Attachments.Add Chemin + Tbl(I)
                        End If
                        VarT = VarT + 1
                    Next I
                End If
            Next P
        End If
 
        'Sauvegarde du mail dans le dossier Communications Clients
        '.SaveAs "O:\" + Arc + "\Communications clients\" + .Subject + ".msg"
 
        'Envoi du mail
        .Send
 
        If .Sent = True Then
            MsgBox "Envoyé"
        End If
 
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub
Cordialement,