Sauvegarder les pièces jointes de fichiers msg

Y compris Power BI, Power Query et toute autre question en lien avec Excel
P
PG59180
Membre habitué
Membre habitué
Messages : 106
Inscrit le : 21 janvier 2013
Version d'Excel : 2003

Message par PG59180 » 25 mai 2018, 09:04

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.
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 9'151
Appréciations reçues : 376
Inscrit le : 16 juin 2013
Version d'Excel : 365 UK Windows 10

Message par h2so4 » 25 mai 2018, 10:20

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
Modifié en dernier par h2so4 le 25 mai 2018, 12:49, modifié 2 fois.
P
PG59180
Membre habitué
Membre habitué
Messages : 106
Inscrit le : 21 janvier 2013
Version d'Excel : 2003

Message par PG59180 » 25 mai 2018, 11:56

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 ?
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 9'151
Appréciations reçues : 376
Inscrit le : 16 juin 2013
Version d'Excel : 365 UK Windows 10

Message par h2so4 » 25 mai 2018, 12:00

Bonjour,

une ligne de code est passée à la trappe. j'ai corrigé le code, voir plus haut.
P
PG59180
Membre habitué
Membre habitué
Messages : 106
Inscrit le : 21 janvier 2013
Version d'Excel : 2003

Message par PG59180 » 25 mai 2018, 12:15

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
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 9'151
Appréciations reçues : 376
Inscrit le : 16 juin 2013
Version d'Excel : 365 UK Windows 10

Message par h2so4 » 25 mai 2018, 13:16

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
P
PG59180
Membre habitué
Membre habitué
Messages : 106
Inscrit le : 21 janvier 2013
Version d'Excel : 2003

Message par PG59180 » 25 mai 2018, 13:50

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
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 9'151
Appréciations reçues : 376
Inscrit le : 16 juin 2013
Version d'Excel : 365 UK Windows 10

Message par h2so4 » 25 mai 2018, 14:42

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
Modifié en dernier par h2so4 le 25 mai 2018, 15:56, modifié 1 fois.
P
PG59180
Membre habitué
Membre habitué
Messages : 106
Inscrit le : 21 janvier 2013
Version d'Excel : 2003

Message par PG59180 » 25 mai 2018, 15:01

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.
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 9'151
Appréciations reçues : 376
Inscrit le : 16 juin 2013
Version d'Excel : 365 UK Windows 10

Message par h2so4 » 25 mai 2018, 15:57

Bonjour,

j'ai corrigé le code. voir ci-dessus.
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message