Outlook vba sauvegarder le ou les fichiers joints d'une sélection de messages
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
- Doevents vba - Conseils pratiques -Visual Basic / VB.NET
- Byval vba - Conseils pratiques -Visual Basic / VB.NET
- Activer macro outlook - Forum Visual Basic
- Vba formular1c1 - Forum Visual Basic
- Vba modulo - Forum Visual Basic
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.