Outlook vba sauvegarder le ou les fichiers joints d'une sélection de messages
3/5 (4 avis)
Vue 11 992 fois - Téléchargée 845 fois
Description
J'ai reçu 12 messages d'un même expéditeur avec pour chacun un fichier joint (une photo JPEG) donc j'ai sélectionné chacun des messages et enregistrer 12 fois le fichier joint.
La macro ne VBA ci dessous permet:
Après sélection multiple des messages à traiter, la macro en VBA permet de sélectionner un disque puis un dossier de sauvegarde et d'enregitrer les fichiers joints.
La macro ne VBA ci dessous permet:
Après sélection multiple des messages à traiter, la macro en VBA permet de sélectionner un disque puis un dossier de sauvegarde et d'enregitrer les fichiers joints.
Source / Exemple :
Public disk As Integer, Chemin As String
'---------------------------------------------------------------------------------------------
'*** D'après un script publié par VBFRance (www.vbfrance.com)
Sub CopierFichierJoint()
Dim OutlookApp As New Outlook.Application
Dim OutlookExp As Outlook.Explorer
Dim OutlookSélex As Outlook.Selection
Dim x As Integer
Dim i As Integer
Dim NomFichier As String
Dim NomFichierTemp As String
Dim DossierDestination As String
Dim DossierParDéfaut As String
Dim DateRéception As String
Dim fs
'Procedure de traitement des messages
Dim folder As String
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
ChoixDuDisk.Show
Select Case disk
Case 1
Choix = ChoixDossierFichier("C:\")
Case 2
Choix = ChoixDossierFichier("J:\")
Case 3
On Error Resume Next
Dir ("A:")
If Err.Number = 52 Then
MsgBox "Pas de disquette dans le lecteur, introduisez une disquette vierge dans le lecteur.", vbOKOnly, "Erreur"
End
End If
Choix = ChoixDossierFichier("A:\")
If Choix = "" Then Choix = "A:"
End Select
If Choix = "" Then End
ChoixDuDisk.Hide
DossierParDéfaut = Choix & "\"
DossierDestination = DossierParDéfaut
Set fs = CreateObject("Scripting.FileSystemObject")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookExp = OutlookApp.ActiveExplorer
Set OutlookSélex = OutlookExp.Selection
If OutlookSélex.Count < 1 Then
MsgBox "Aucun message n'est sélectionné.", vbExclamation, "Erreur"
Exit Sub
End If
For x = 1 To OutlookSélex.Count
DoEvents
DateRéception = OutlookSélex.Item(x).ReceivedTime
NomFichier = OutlookSélex.Item(x)
NomFichier = NomFichier & " (" & DateRéception & ")"
NomFichier = Remplacement(NomFichier, "/", ".")
NomFichier = Remplacement(NomFichier, "\", "_")
NomFichier = Remplacement(NomFichier, ":", ".")
NomFichier = Remplacement(NomFichier, "*", "_")
NomFichier = Remplacement(NomFichier, "?", "_")
NomFichier = Remplacement(NomFichier, Chr(34), "_")
NomFichier = Remplacement(NomFichier, "<", "_")
NomFichier = Remplacement(NomFichier, ">", "_")
NomFichier = Remplacement(NomFichier, "|", "_")
i = 1
NomFichierTemp = NomFichier
On Error GoTo Erreur
Set myItem = OutlookSélex.Item(x)
If myItem.Attachments.Count > 0 Then
For pi = 1 To myItem.Attachments.Count
Set myAttachments = myItem.Attachments
'sauvegarde du piece attachee
myAttachments.Item(pi).SaveAsFile DossierDestination & "\" _
& myAttachments.Item(pi).DisplayName
Next
Else
MsgBox "Le message " & NomFichier & " ne contient pas de fichier joint.", vbExclamation, "Erreur"
End If
Do While fs.FileExists(DossierDestination & NomFichier & ".msg") = True
NomFichier = NomFichierTemp & " - " & i
i = i + 1
Loop
Next x
GoTo Fin
End
Erreur:
MsgBox "Le dossier que vous avez indiqué (" & DossierDestination & ") n'existe pas." _
& Chr(10) & "Les messages n'ont pas été copiés.", vbOKOnly, "Erreur"
Fin:
End Sub
Function Remplacement(ByVal Texte As String, CarARemplacer As String, CarRemplacement As String) As String
Dim c As Integer
Do
c = InStr(Texte, CarARemplacer)
If c Then
Texte = Left(Texte, c - 1) + CarRemplacement + Mid(Texte, c + Len(CarARemplacer))
End If
Loop While c
Remplacement = Texte
End Function
Function ChoixDossierFichier(Racine, Optional SelType As Byte = 0)
Dim objShell, objFolder, Chemin, SecuriteSlash, FlagChoix&, Msg$
If SelType = 0 Then
FlagChoix = &H1&: Msg = "Choisissez un dossier :"
Else
FlagChoix = &H4000&: Msg = "Choisissez un fichier :"
End If
'modifier le chemin par défaut ci dessous
'If disk = 1 Then Racine = "C:\Documents and Settings\ZiganPhil\Mes documents\ZIGAN"
'If disk = 2 Then Racine = "J:\TELECHARGEMENT"
Set objShell = CreateObject("Shell.Application")
'le troisième paramètre permet de choisir
'la sélection d'un dossier ou d'un fichier (0 ou 1)
'le dernier paramètre permet de choisir le dossier racine
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, FlagChoix, Racine)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If Chemin = "" Then Exit Function
If objFolder.Title = "Bureau" Then
Chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
Chemin = ""
End If
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
Chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoixDossierFichier = Chemin
End Function
Codes Sources
A voir également
- Outlook vba sauvegarder le ou les fichiers joints d'une sélection de messages
- Macro en vba pour effacer les fichiers joints d'un ou plusieurs messages... - Codes sources - Visual Basic / VB.NET (VBA)
- VBA sauvegarde et supression de fichier excel ✓ - Forum - Visual Basic 6
- Extraire pièce jointe outlook vba - Guide
- VBA - Macro sauvegarde à tord un fichier toto.docx en format 2003 sous word 2007 ✓ - Forum - Visual Basic 6
- Lire un fichier joint dans un courrier sauvegardé dans un répertoire ✓ - Forum - Visual Basic 6
12 mai 2011 à 12:36
J'ai donc effectué cette modif (peut-être pas clean), mais qui semble fonctionner
On Error GoTo Erreur
Set myitem = OutlookSélex.Item(x)
If myitem.Attachments.Count > 0 Then
For pi = 1 To myitem.Attachments.Count
Set myAttachments = myitem.Attachments
'sauvegarde du piece attachee
' renomme
'Nom du fichier sans extension
Pos = InStr(1, myAttachments.Item(pi).FileName, ".", 1)
NomFichierSansExtension = Left(myAttachments.Item(pi).FileName, Pos - 1)
'Extension du fichier
Extension = Right(myAttachments.Item(pi).FileName, 3)
myAttachments.Item(pi).SaveAsFile DossierDestination & "" & NomFichierSansExtension & x & "." & Extension
FichierBon = True
Next
Else
MsgBox "Le message " & NomFichier & " ne contient pas de fichier joint.", vbExclamation, "Erreur"
End If
'Do While fs.FileExists(DossierDestination & NomFichier & ".msg") = True
' NomFichier = NomFichierTemp & " - " & i
' i = i + 1
'Loop
J'ai l'impression que la boucle ne fait pas bien son travail...
17 mars 2005 à 01:42
très bien fait.
si on peut ajouter ses origines dans sa résumé (auteur, mot-clé, titre,...) de propriétés, c'est encore mieux
18 févr. 2005 à 09:52
J'ai déja un code permettant de le faire mais je n'avais jamais finalisé d'interface.
Je pense que je vais faire un mix des deux !
Bon courage !
18 févr. 2005 à 09:52
J'ai déja un code permettant de le faire mais je n'avais jamais finalisé d'interface.
Je pense que je vais faire un mix des deux !
Bon courage !
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.