Enregistrement des fichiers d'un mail via une macro

Le 13/10/2018 à 20:16

Bonjour Tout le Monde,

Est ce que quelqu'un a déjà tenté d'enregistrer les fichiers d'un email à l'aide d'une macro ?

Si oui ! Est il possible de partager avec nous son expérience ?

Merci d'avance.

Le 14/10/2018 à 09:34

Bonjour,

J'ai trouvé ce code sur un autre forum qui fonctionne dans Outlook, si tu as des connaissances en VBA, il te sera facile de l'adapter pour un appel depuis Excel. Je l'ai laissé tel quel (juste quelques variables qui n'étaient pas déclarées, que j'ai rajouté), toute la partie qui demande le lecteur et le dossier peut être simplifiée. Cette procédure récupère tous les fichiers joints se trouvant dans le dossier Outlook choisi mais il est possible de faire une routine pour récupérer un fichier particulier :

'http://www.developpez.net/forums/d1377463/logiciels/microsoft-office/outlook/vba-outlook/macro-vba-sauvegarde-pieces-jointes-p-objets-corps-mail-dossiers/
'-- Variable globale contenant le répertoire de référence de sauvegarde
Dim REP_TOP As String

Sub Extrait_Pieces_Jointes()
'----------------------------------------------------------------------
' Routine :    Extrait_Pieces_Jointes
'----------------------------------------------------------------------
' Paramètres : aucun ...
'----------------------------------------------------------------------
'   retour :    Boite de dialogue "Terminé"
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

    Dim myNameSpace As Namespace, fld As MAPIFolder, pfld As MAPIFolder, sfld As MAPIFolder
    Dim myItem As MailItem, Piece As Attachment
    Dim doc As String, rep As String
Dim test
    '-- Choix et contrôle du disque de destination
    rep = InputBox("Sur quel disque ?", "Question", "C:")
    On Error Resume Next
    ChDrive rep
    test = Err
    On Error GoTo 0

    If test Then
        MsgBox "Disque " & rep & " inaccessible"
        Exit Sub
    End If

    REP_TOP = rep & "\"

    '-- Choix et contrôle / création du répertoire de base
    rep = InputBox("Dans quel répertoire ?", "Question", "\temp\test\")

    test = waaps_creedir(rep)

    If Not test Then
        MsgBox "Répertoire " & rep & " inaccessible"
        Exit Sub
    End If

    '-- Initialisation de la variable globale du répertoire de référence
    REP_TOP = REP_TOP & "\" & rep
    REP_TOP = Replace(REP_TOP, "/", "\")
    REP_TOP = Replace(REP_TOP, "\\", "\")

    '-- Récupération de l'espace nommé MAPI
    Set myNameSpace = CreateObject("Outlook.Application").GetNamespace("MAPI")

    '-- Choix du dossier à traiter ... c'est un MAPIFolder
    Set pfld = myNameSpace.PickFolder

    '-- Si l'utilisateur renonce on s'en va
    If pfld Is Nothing Then Exit Sub

    '-- appel de la routine sauvefolder ...
    sauvefolder pfld, ""

    MsgBox "terminé"

End Sub

Sub sauvefolder(fld As MAPIFolder, ByVal suf As String)
'----------------------------------------------------------------------
' Routine :    sauvefolder (routine récursive...)
'----------------------------------------------------------------------
' Paramètres :
'    fld : Le MAPIFolder à traiter
'    suf : localisation /nomdedossier/nomdedossier2/
'----------------------------------------------------------------------
'   retour :    Aucun
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

'-- on entretient la localisation sur la base du nom de dossier courant
    suf = suf & fld.Name & "\"

    '-- On envoie une info dans la fenêtre debug pour ceux qui aiment voir ce qui se passe
    Debug.Print suf & fld.items.Count

    '-- On tourne sur tous les éléments du dossier courant
    For i = 1 To fld.items.Count
        '-- Si c'est un élément de type Mail alors on sauvegarde les pièces jointes associées
        If fld.items(i).Class = olMail Then sauvefichier fld.items(i), suf
        '-- Pour voir ce qui se passe sans tout faire ... enlever le commentaire ci-dessous
        'If i = 2 Then Exit For
    Next

    '-- On tourne sur tous les sous-dossiers du dossier courant
    For i = 1 To fld.Folders.Count
        '-- appel récursif de la fonction sauvefolder
        sauvefolder fld.Folders(i), suf
    Next

End Sub

Sub sauvefichier(myItem As MailItem, ByVal suf As String)
'----------------------------------------------------------------------
' Routine :    sauvefichier (routine récursive...)
'----------------------------------------------------------------------
' Paramètres :
'    myItem : l'item Mail à traiter
'    suf : localisation /nomdedossier/nomdedossier2/
'----------------------------------------------------------------------
'   retour :    Aucun
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

    Dim Piece As Attachment

    '-- on s'assure de la création / existence du répertoire de stockage
    'AJOUT OLIV- pour classement selon l'année et le mois de réception
    suf = Format(myItem.ReceivedTime, "YYYY") & "\" & Format(myItem.ReceivedTime, "YYYY-MM (MMMM)") & "\"
    waaps_creedir (suf)

    '-- On boucle sur les pièces jointes du message (si il y en a)
    For j = 1 To myItem.Attachments.Count
        '-- Initialisation de l'objet Pièce Jointe
        Set Piece = myItem.Attachments(j)
        '-- Sauvegarde du fichier correspondant.
        Piece.SaveAsFile REP_TOP & suf & j & "_" & Piece.Filename
    Next
    Set Piece = Nothing
End Sub

Function waaps_creedir(lerep As String) As Boolean
'----------------------------------------------------------------------
' FUNCTION :    waaps_creedir
'               Création d'un répertoire (récursif)
'----------------------------------------------------------------------
' Paramètres :
'   rep :       répertoire à créer par son chemin relatif % au root
'----------------------------------------------------------------------
'   retour :    True si le répertoire est créé
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
    Dim fso As FileSystemObject, i As Integer, retour As Boolean
    Dim rp As String, r

    Set fso = CreateObject("Scripting.filesystemobject")

    rp = Replace(lerep, "\", "/")
    rp = Replace(rp, "//", "/")
    rep = Split(rp, "/")
    r = REP_TOP
    retour = True
    For i = 0 To UBound(rep)
        If (rep(i) <> "") Then
            r = r & rep(i) & "\"
            If (Not fso.FolderExists(r)) Then
                fso.CreateFolder (CStr(r))
                If (Not fso.FolderExists(r)) Then retour = False
            End If
        End If
    Next
    Set fso = Nothing
    waaps_creedir = retour
End Function
Le 14/10/2018 à 11:50

Re,

Voici le code pour être exécuté depuis Excel. Voir dans la sub Fichier() pour adapter les extensions à exclurent :

'Code adapté depuis la source de BRUNO VILLACAMPA
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
Dim DosDestination As String

Sub ExtrairePJ()

    Dim AppOutLook As Object
    Dim EspNom As Object
    Dim DosOutlook As Object

    'choix du dossier de destination
    DosDestination = ChoixDossier: If DosDestination = "" Then Exit Sub

    DosDestination = DosDestination & "\"

    Set AppOutLook = CreateObject("Outlook.Application")

    'Récupération de l'espace nommé MAPI
    Set EspNom = AppOutLook.GetNamespace("MAPI")

    'ici, choix du dossier avec "GetDefaultFolder()"
    '3 dossier "Éléments supprimés", 4 = "Boîte d'envoi", 5 = "Éléments envoyés", 6 = "Boîte de réception"
    '9 = "Calendrier", 10 = "Contacts", 11 = "Journal", 12 = "Notes", 13 = "Tâches", 14, 15 = "Rappels", 16 dossier "Brouillons"

    'Set DosOutlook = EspNom.GetDefaultFolder(6) 'ici, dossier "Boîte de réception"

    'Choix du dossier à faire dans Outlook où se trouve les fichiers joints à récupérer et fin si pas de choix !
    'cette ligne de code peut être supprimé et utiliser à la place la ligne ci-dessus où on défini le dossier pas défaut
    Set DosOutlook = EspNom.PickFolder: If DosOutlook Is Nothing Then Exit Sub

    'appel de la routine Dossier ...
    Dossier DosOutlook, DosDestination

    MsgBox "Terminé !"

End Sub

Sub Dossier(DosOutlook As Object, ByVal Dos As String)

    Dim I As Integer

    'on entretient la localisation sur la base du nom de dossier courant
    Dos = Dos & DosOutlook.Name & "\"

    For I = 1 To DosOutlook.items.Count

        '-- Si c'est un élément de type Mail alors on sauvegarde les pièces jointes associées
        If DosOutlook.items(I).Class = 43 Then Fichier DosOutlook.items(I), Dos

    Next

    'boucle sur les sous-dossiers du dossier en cours
    'appel récursif de la fonction Dossier
    For I = 1 To DosOutlook.Folders.Count: Dossier DosOutlook.Folders(I), Dos: Next I

End Sub

Sub Fichier(Message As Object, ByVal Dos As String)

    Dim Piece As Object
    Dim J As Integer

    'bouclage sur les pièces jointes du message (si il y en a)
    For J = 1 To Message.Attachments.Count

        Set Piece = Message.Attachments(J)

        'extansion de fichier à éviter...
        Ext = LCase(Right(Piece.Filename, Len(Piece.Filename) - InStr(Piece.Filename, ".")))

        Select Case Ext

            'fichiers à éviter
            Case "png", "html", "jpg", "gif"

            'enregistrement
            Case Else: Piece.SaveAsFile DosDestination & "_" & Piece.Filename

        End Select

    Next

    Set Piece = Nothing

End Sub

Function ChoixDossier() As Variant

    With Application.FileDialog(4)
        If .Show = -1 Then ChoixDossier = .SelectedItems(1)
    End With

End Function
Le 26/10/2018 à 13:14

PArfait, je vais essayer de la tester et revenir vers toi si je bloque quelques parts merciii

Rechercher des sujets similaires à "enregistrement fichiers mail via macro"