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.