jibi23
09-13-2013, 09:06 AM
Hi,
My system is :
Win7
Outlook / Office 2010
64bits
I am working on a macro VBA under Outlook2010 which should allow me to save the entire hierarchy of an inbox folders and the matching emails + attached docs
I have this code below which works for selecting the inbox folder to backup, and then the harddrive where to save and then save the attached docs,
I still have 3 problems :
- I wish to save only attached files with xls, xlsx, ppt, pptx, doc, docx, pdf.
- I wish to recover the mail body in the matching hard drive folder.
- I wish to insert the mail subject in the file name of the backuped attached document on the hard drive.
Microsoft Scripting Runtime activation is required
'-- 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
'-- 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
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
Any kind of help would be appreciated,
Thanks by advance,
Regards
My system is :
Win7
Outlook / Office 2010
64bits
I am working on a macro VBA under Outlook2010 which should allow me to save the entire hierarchy of an inbox folders and the matching emails + attached docs
I have this code below which works for selecting the inbox folder to backup, and then the harddrive where to save and then save the attached docs,
I still have 3 problems :
- I wish to save only attached files with xls, xlsx, ppt, pptx, doc, docx, pdf.
- I wish to recover the mail body in the matching hard drive folder.
- I wish to insert the mail subject in the file name of the backuped attached document on the hard drive.
Microsoft Scripting Runtime activation is required
'-- 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
'-- 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
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
Any kind of help would be appreciated,
Thanks by advance,
Regards