[Outlook 2010] Macro VBA de sauvegarde des pièces jointes + objets et corps de mail par dossiers | ||
---|---|---|
Inscription: 28/03/2013
Messages:
3
Système d'exploitation: Mac Version Excel utilisée: 2008 |
Posté le : 12-09-2013 12h51
Bonjour, Mon système :
Je travaille à partir d'un modèle téléchargé sur internet sur une macro VBA qui devrait me permettre de récupérer sur mon disque dur toute l'arborescence, avec les corps de mail, objet et PJ d'une boite de réception Outlook.
Le code actuel ci-dessous, me permet de choisir dans quel répertoire de l'arborescence de la boite de réception démarrer la collecte, puis de choisir l'emplacement de sauvegarde sur mon disque dur, et enfin de lancer la récup des PJ.
Je rencontre 3 besoins non résolus sur la macro actuelle :
-Je souhaite pouvoir filtrer les PJ sauvegardées en éliminant de la requête les fichiers autres que xls, xlsx, ppt, pptx, doc, docx, pdf.
J'ai essayé plusieurs techniques de filtrage d'extension de fichiers etc.. cela ne marche pas, je vous poste donc la macro d'origine sans ces 3 fonctions ci-dessus:
Il est nécessaire d'activer Microsoft Scripting Runtime dans l’éditeur VBA d’outlook pour exécuter la macro.
'-- 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 Je précise que je sais qu'il existe des Soft et freeware pour le faire, mais on ne peut en utiliser aucun sur nos postes de travail, donc la seule solution est la macro.
Quelqu'un aurait-il la motivation de jeter un œil ? |
|
|
Re: Excel Mac 2008 - Recopier un nombre sur plusieurs lignes | ||
---|---|---|
Inscription: 28/03/2013
Messages:
3
Système d'exploitation: Mac Version Excel utilisée: 2008 |
Posté le : 12-09-2013 12h48
Merci bcp, Cela a fonctionné. Cdt |
|
|
Excel Mac 2008 - Recopier un nombre sur plusieurs lignes | ||
---|---|---|
Inscription: 28/03/2013
Messages:
3
Système d'exploitation: Mac Version Excel utilisée: 2008 |
Posté le : 28-03-2013 08h58
Bonjour,
Mais je n'arrive pas a reproduire automatiquement ma formule pour tout les nombres suivants.Je travaille sous Excel Mac 2008 donc sans VBA. Dans le fichier exemple ci-joint, je voudrais recopier 95 fois (95 lignes) chaque nombre de la colonne de gauche dans la colonne de droite comme j'ai commencé a le faire. Y a t il une formule ou une manip sans VBA me permettant de le faire ? Sinon, je suis preneur en dernier recours d'une solution macro/VBA, que j'executerais sur une autre machine. Merci à vous pour votre aide, Cdt |
|
|