VBA : copier fichiers joints

Le
David
Bonjour à tous,

Sous VBA comment modifier le code (extrait) ci-dessous
pour que lorsque le programme rencontre un fichier
d'un nom déjà existant il offre le choix entre l'écraser
ou ne pas l'enregistrer ?

Merci d'avance.

--
a+ Jean-Pol Site Web : www.colovid.be
Site Web perso pour le fun : http://users.skynet.be/DAVID/
Cette page est transmise avec des électrons 100% recyclés.



Public disk As Integer, Chemin As String
Dim FichierBon As Boolean

'
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("D:")
Case 2
Choix = ChoixDossierFichier("K:")
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:"
Case 4
Choix = ChoixDossierFichier("L:")

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
FichierBon = True
Next
Else
MsgBox "Le message " & NomFichier & " ne contient pas de
fichier joint.", vbExclamation, "Message d'avertissement"
End If

Do While fs.FileExists(DossierDestination & NomFichier & ".msg")
= True
NomFichier = NomFichierTemp & " - " & i
i = i + 1
Loop
Next x
If FichierBon = True Then MsgBox "Sauvegarde des pièces jointes
terminée", vbInformation, "Enregistrement"

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:
FichierBon = False
End Sub
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Geo
Le #19105031
Bonsoir Jean-Paul

Sous VBA comment modifier le code (extrait) ci-dessous
pour que lorsque le programme rencontre un fichier
d'un nom déjà existant il offre le choix entre l'écraser
ou ne pas l'enregistrer ?



Faudra dire au programmeur de mettre des commentaires dans ses
programmes ce serait plus simple pour les modifier.

Je tenterais une modification comme ceci :
'sauvegarde du piece attachee
Dim NomPj As String
Dim Réponse As Long
NomPj = DossierDestination & "" _
& myAttachments.Item(Pi).DisplayName
myAttachments.Item(Pi).SaveAsFile NomPj
If fs.FileExists(NomPj) Then
Réponse = MsgBox("Le fichier " & vbCrLf & NomPj & _
vbCrLf & " existe déjà. L'écraser ?", vbYesNo)
If Réponse = vbYes Then
' on l'écrase
myAttachments.Item(Pi).SaveAsFile NomPj
Else
' ignorer
' prévoir un message ?
End If
Else
myAttachments.Item(Pi).SaveAsFile NomPj
End If
FichierBon = True
Pour se repérer, j'ai gardé la ligne qui précède et celle qui suit.

Pas testé, évidemment.

--
A+
David
Le #19105221
Bonjour Geo,

Merci pour la peine que vous vous êtes donné.
Pas facile de rentrer dans un programme dont
on n'est pas le créateur.
Merci en tout cas.

--
a+ Jean-Pol
Site Web : www.colovid.be
Site Web perso pour le fun : http://users.skynet.be/DAVID/
Cette page est transmise avec des électrons 100% recyclés.

"Geo"
Bonsoir Jean-Paul

Sous VBA comment modifier le code (extrait) ci-dessous
pour que lorsque le programme rencontre un fichier
d'un nom déjà existant il offre le choix entre l'écraser
ou ne pas l'enregistrer ?



Faudra dire au programmeur de mettre des commentaires dans ses programmes
ce serait plus simple pour les modifier.

Je tenterais une modification comme ceci :
'sauvegarde du piece attachee
Dim NomPj As String
Dim Réponse As Long
NomPj = DossierDestination & "" _
& myAttachments.Item(Pi).DisplayName
myAttachments.Item(Pi).SaveAsFile NomPj
If fs.FileExists(NomPj) Then
Réponse = MsgBox("Le fichier " & vbCrLf & NomPj & _
vbCrLf & " existe déjà. L'écraser ?", vbYesNo)
If Réponse = vbYes Then
' on l'écrase
myAttachments.Item(Pi).SaveAsFile NomPj
Else
' ignorer
' prévoir un message ?
End If
Else
myAttachments.Item(Pi).SaveAsFile NomPj
End If
FichierBon = True
Pour se repérer, j'ai gardé la ligne qui précède et celle qui suit.

Pas testé, évidemment.

--
A+




Geo
Le #19105381
Re

Merci pour la peine que vous vous êtes donné.
Pas facile de rentrer dans un programme dont
on n'est pas le créateur.



Et on craint de casser autre chose.

Tenez-nous au courant.

--
A+
David
Le #19108011
Bonjour Geo,

Et on craint de casser autre chose.


Exactement; c'est pour cela que j'ai préféré poser la
question sur le forum :-)))

Votre code m'inspirant toute confiance je
m'y suis cantonné malgré que cela ne fonctionnait pas.
En effet, quelque soit le choix le fichier était à nouveau
enregistré. Ce que je n'ai pas compris tout de suite - bien sûr.

Un ligne de code s'est en effet malicieusement infiltrée dans votre projet
ici à hauteur de la flèche :

NomPj = DossierDestination & "" _
& myAttachments.Item(Pi).DisplayName
-----> myAttachments.Item(Pi).SaveAsFile NomPj
If fs.FileExists(NomPj) Then

Ensuite, en lisant des pages sur Internet, j'ai supprimé
ces quelques lignes du mon codes initiale :

'Do While fs.FileExists(DossierDestination & NomFichier & ".msg") = True
' NomFichier = NomFichierTemp & " - " & i
' i = i + 1
'Loop

Maintenant, ça à l'air de fonctionner.

Un grand merci car je pense que sans vous je n'y serais pas arrivé.

--
a+ Jean-Pol
Site Web : www.colovid.be
Site Web perso pour le fun : http://users.skynet.be/DAVID/
Cette page est transmise avec des électrons 100% recyclés.


"Geo"
Re

Merci pour la peine que vous vous êtes donné.
Pas facile de rentrer dans un programme dont
on n'est pas le créateur.



Et on craint de casser autre chose.

Tenez-nous au courant.

--
A+




Geo
Le #19110081
Bonsoir Jean-Pol

Un ligne de code s'est en effet malicieusement infiltrée dans votre projet
ici à hauteur de la flèche :

NomPj = DossierDestination & "" _
& myAttachments.Item(Pi).DisplayName
-----> myAttachments.Item(Pi).SaveAsFile NomPj
If fs.FileExists(NomPj) Then



Vous avez tout à fait raison, j'ai omis de la supprimer.

Ensuite, en lisant des pages sur Internet, j'ai supprimé
ces quelques lignes du mon codes initiale :

'Do While fs.FileExists(DossierDestination & NomFichier & ".msg") = True
' NomFichier = NomFichierTemp & " - " & i
' i = i + 1
'Loop



Ca a été ma grande interrogation hier.
J'en suis arrivé à la conclusion que le message lui-même pouvait être
enregistré dans ce dossier et pour éviter d'écraser un message par un
autre de même "nom" on ajoutait des caractères derrière.
Vous pourriez le vérifier dans le reste du code.

--
A+
Publicité
Poster une réponse
Anonyme