Sauvegarder les pièces jointes de fichiers msg

Bonjour,

Dans un dossier j'ai une multitude de fichiers msg qui contiennent une ou plusieurs pièces-jointes qui sont des fichiers Excel.

Est-il possible de créer une macro pour :

(sous excel pas sous Outlook car je n'ai pas la possibilité d'écrire de macro sous Outlook (fonctions non activées sur mon poste)

1) Ouvrir chaque fichier msg sans avoir besoin d'indiquer le nom du fichier à ouvrir

2) Enregistrer la ou les pièces jointes qui se trouvent dans le fichier msg dans un dossier sur mon lecteur C (MESPIECES)

3) si la pièce jointe est un "doublon" d'un fichier excel déjà enregistré alors l'enregistrer tout de même mais avec la mention "Doublon x" (x étant le numéro du fichier doublon, par exemple s'il n'y a qu'un fichier doublon alors x serait égal à 1, par contre s'il y en a 4 on aurait Doublon 1, Doublon 2, Doublon 3, Doublon 4

Vous me rendriez un service énorme si c'était possible car j'ai plusieurs milliers de fichiers dans lesquels je dois récupérer toutes les pièces jointes.

Merci beaucoup.

Bonjour,

une proposition (vérifier et adapter éventuellement les répertoires dans le code)

Sub aargh()
Dim f(), i As Long, fso, ch$, chs$, fn$, msg, ctr As Long, fts, k As Long, oa, attch
    set oa=createobject("outlook.application")

' à adapter
    ch = "c:\mespieces\"    ' répertoire dans lequel sont stockés les fichiers msg
    chs = "c:\mespieces\"    'répertoire dans lequel sauvegarder les attachments

    fn = Dir(ch & "*.msg")
    While fn <> ""
        k = k + 1
        ReDim Preserve f(k)
        f(k) = ch & fn
        fn = Dir
    Wend
    For i = 1 To k

        Set msg = oa.Session.OpenSharedItem(f(i))

        For Each attch In msg.Attachments
            fts = chs & attch.Filename
            ctr = 0
            While Dir(fts) <> ""
                ctr = ctr + 1
                fts = chs & "doublon " & ctr & " " & attch.Filename
            Wend
            attch.SaveAsFile fts
        Next
    Next i
End Sub

Bonjour,

Merci beaucoup pour votre aide.

J'ai placé le code dans un module de classeur excel.

Le code bloque sur : Set msg = oa.Session.OpenSharedItem(f(i))

Avec une mention "Objet requis".

Une idée ?

Bonjour,

une ligne de code est passée à la trappe. j'ai corrigé le code, voir plus haut.

Génial...

Merci beaucoup...

Une ultime demande si possible...

Dans le fichier où sont enregistrés les fichiers :

S'il s'agit d'un fichier excel

L'enregistrer (je suppose qu'il faut d'abord l'ouvrir)

en construisant son nom ainsi :

texte de l'onglet 1 (moins le premier mot suivi d'un espace)

suivi d'un espace

et de la date contenu dans la cellule C4

(dans la cellule C4, la valeur est au format date séparée de /)

J'aimerais que la date soit au format 25052018 (sans /)

et idem pour les doublons, si un fichier devait être en doublon, alors l'enregistrer quand même mais en le qualifiant de "Doublon x"...

Merci beaucoup

Bonjour,

une proposition,

non testé !

Sub aargh()
    Dim f(), i As Long, fso, ch$, chs$, fn$, msg, ctr As Long, fts, k As Long, oa, attch
    Set oa = CreateObject("outlook.application")

    ' à adapter
    ch = "c:\mespieces\"    ' répertoire dans lequel sont stockés les fichiers msg
    chs = "c:\mespieces\"    'répertoire dans lequel sauvegarder les attachments

    'on construit un tableau avec tous les fichiers msg
    fn = Dir(ch & "*.msg")
    While fn <> ""
        k = k + 1
        ReDim Preserve f(k)
        f(k) = ch & fn
        fn = Dir
    Wend

    ' on prend 1 à 1 chacun des fichiers msg
    For i = 1 To k
        'on charge le fichier msg dans outlook
        Set msg = oa.Session.OpenSharedItem(f(i))

        'on examine les attachments
        For Each attch In msg.Attachments
            'fichier excel ?
            If InStr(UCase(attch.Filename), ".XLS") > 0 Then
                fts = chs & attch.Filename
                ext = Mid(fts, InStrRev(fts, "."))
                ctr = 0
                'on vérifie que le nom n'existe pas déjà
                While Dir(fts) <> ""
                    ctr = ctr + 1
                    fts = chs & "doublon " & ctr & " " & attch.Filename
                Wend
                attch.SaveAsFile fts    'on sauve le fichier excel
                'on ouvre le fichier excel
                Set wb = Workbooks.Open(fts, ReadOnly:=True)
                With wb.Sheets(1)
                    nom = Mid(.Name, InStr(.Name, " ") + 1) & " " & Format(.Range("C4"), "ddmmyyyy")
                End With
                ftsx = chs & "doublon " & ctr & " " & nom & ext
                ctr = 0
                'on vérifie que le nom n'existe pas déjà
                While Dir(ftsx) <> ""
                    ctr = ctr + 1
                    ftsx = chs & "doublon " & ctr & " " & nom & ext
                Wend
                wb.SaveAs ftsx    'on sauve le fichier sous son nouveau nom
                Kill fts  'on supprime l'ancienne sauvegarde
                wb.Close False    'on ferme le fichier excel
            End If
        Next
    Next i
End Sub

Bonjour,

On progresse mais,

Avec le premier code j'obtenais 164 fichiers excel

Avec le second code j'obtiens 76 fichiers

Sur les 76 fichiers obtenus, 75 ont un nom qui commence par "Doublon"

Je crois comprendre d'où ça vient...

Il y a des feuilles masquées et la feuille qui doit servir à construire le nom n'est donc pas forcément la feuille 1

Serait-il possible de modifier le code pour que le nom soit construit à partir de la feuille qui a le nom le plus long ?

en conservant la même règle de supprimer le premier mot de ce nom...

Merci beaucoup

bonjour,

une version adaptée toujours non testée

Sub aargh()
    Dim f(), i As Long, fso, ch$, chs$, fn$, ext$, lnws$, nom$, msg, ctr As Long, fts$, ftsx$, k As Long, oa, attch, wb, sh
    Set oa = CreateObject("outlook.application")

    ' à adapter
    ch = "c:\mespieces\"    ' répertoire dans lequel sont stockés les fichiers msg
    chs = "c:\mespieces\"    'répertoire dans lequel sauvegarder les attachments

    'on construit un tableau avec tous les fichiers msg
    fn = Dir(ch & "*.msg")
    While fn <> ""
        k = k + 1
        ReDim Preserve f(k)
        f(k) = ch & fn
        fn = Dir
    Wend

    ' on prend 1 à 1 chacun des fichiers msg
    For i = 1 To k
        'on charge le fichier msg dans outlook
        Set msg = oa.Session.OpenSharedItem(f(i))

        'on examine les attachments
        For Each attch In msg.Attachments
            'fichier excel ?
            If InStr(UCase(attch.Filename), ".XLS") > 0 Then
                fts = chs & attch.Filename
                ext = Mid(fts, InStrRev(fts, "."))
                ctr = 0
                'on vérifie que le nom n'existe pas déjà
                While Dir(fts) <> ""
                    ctr = ctr + 1
                    fts = chs & "doublon " & ctr & " " & attch.Filename
                Wend
                attch.SaveAsFile fts    'on sauve le fichier excel
                'on ouvre le fichier excel
                Set wb = Workbooks.Open(fts, ReadOnly:=True)
                lnws = ""
                For Each sh In wb.Sheets
                    If Len(sh.Name) > Len(lnws) Then lnws = sh.Name
                Next
                Set sh = Sheets(lnws)
                With sh
                    nom = Mid(.Name, InStr(.Name, " ") + 1) & " " & Format(.Range("C4"), "ddmmyyyy")
                End With
                ftsx = chs &  nom & ext
                ctr = 0
                'on vérifie que le nom n'existe pas déjà
                While Dir(ftsx) <> ""
                    ctr = ctr + 1
                    ftsx = chs & "doublon " & ctr & " " & nom & ext
                Wend
                wb.SaveAs ftsx    'on sauve le fichier sous son nouveau nom
                Kill fts  'on supprime l'ancienne sauvegarde
                wb.Close False    'on ferme le fichier excel
            End If
        Next
    Next i
End Sub

Merci beaucoup pour vos efforts.

Je reste avec un problème que je vais essayer de solutionner seul, tous les fichiers sont nommés "Doublon..." alors que tous ne le sont pas.

Je vais essayer de comprendre votre code et de l'adapter.

Bon week-end.

Bonjour,

j'ai corrigé le code. voir ci-dessus.

Rechercher des sujets similaires à "sauvegarder pieces jointes fichiers msg"