3/5 (4 avis)
Vue 11 992 fois - Téléchargée 845 fois
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
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.