1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
| '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 |
Partager