copie de fichier dans sous repertoire

[pobrouwers]

Bonjour le forum,
Quelqu'un a-t-il en stock, un code qui permettrait de faire une copie d'un fichier dans tous les sous-repertoires d'un répertoire que l'on pourrait choisir grâce à un 'browser folder' ?
Merci d'avance...
Bonne journée !

 

[Blunet]

Salut pobrouwers,
je ne pense pas qu'un browser puisser permettre des sélections multiples. Donc le code que je te propose ici permet de sélectionner à chaque fois l'emplacement de destination. Il ne s'agit pas d'une simple copie mais de nouveaux enregistrements (presque pareil).

Sub Kopi()
Dim OuvFich: Dim Nbre, i As Integer
Nbre = InputBox('Sélectionner le nombre d'emplecement de destination', _
' Copies multiples -- Chemins ')

For i = 1 To Nbre
Application.Dialogs(xlDialogSaveAs).Show
Next i

End Sub

J'ai trouvé cette façon plus simple si j'ai bien compris ton pb.

Ciao

 

[pobrouwers]

Merci Blunet,

Mais il ne s'agit pas de selection multiple mais plutot choisir un répertoire et ensuite lister tous les sous repertoires.
je vais essayer tout de meme d'adapter ton code.
Si quelqu'un à une autre idée, elle est la bienvenue ;-)
Merci

 

[MichelXld]

bonjour Pobrouwers , bonjour Blunet

peux tu repréciser ta demande

dans ton 1er message tu indiques

un code qui permettrait de faire une copie d'un fichier dans tous les sous-repertoires d'un répertoire que l'on pourrait choisir grâce à un 'browser folder' ?

dans le 2eme message

choisir un répertoire et ensuite lister tous les sous repertoires.

peux tu expliquer exactement ce que tu souhaites réliser


bonne journée
MichelXld

 

[pobrouwers]

Ce que je souhaite, c'est de pouvoir choisir un répertoire a l'aide d'un 'browser folder' et d'enregistrer ou faire une copie d'un fichier xl (ce fichier est soit le fichier sur lequel la macro est installée soit un autre fichier xl, ce qui serait encore mieux) dans tous les sous-répertoire du répertoire choisi.

 

[MichelXld]

rebonjour Pobrouwers

ci joint une démo de Pascal pour choisir un répertoire

Lien supprimé


sinon voici un exemple qui copie un fichier dans tous les sous répertoires d'un dossier cible

l'exemple ne prend pas en compte les erreurs si un fichier portant le meme nom existe déja dans un des dossiers

Attention : je te conseilles d'ajouter un MsgBox de confirmation avant de lancer ta procedure car si tu sélectionnes directement la racine C:\\\\\\\\ tu vas créer des fichiers dans tous les repertoires de ton disque

necessite d'activer la reference Microsoft Scripting RunTime


Sub copieFichierDansTousLesSousRepertoires()

ListFilesInFolder 'C:\\\\\\\\Documents and Settings\\\\\\\\michel\\\\\\\\excel', True

'--------------------------------------------------------------------
'synthaxe : FileCopy 'source', 'destination'
FileCopy 'C:\\\\\\\\fichierSource.txt', 'C:\\\\\\\\Documents and Settings\\\\\\\\michel\\\\\\\\excel\\\\\\\\copieFichier.txt'
'--------------------------------------------------------------------

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' adapté de Ole P Erlandsen
'necessite d'activer la reference Microsoft Scripting RunTime
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder

Set Fso = CreateObject('Scripting.FileSystemObject')
Set SourceFolder = Fso.GetFolder(SourceFolderName)

For Each SubFolder In SourceFolder.SubFolders

'--------------------------------------------------------------------
'synthaxe : FileCopy 'source', 'destination'
FileCopy 'C:\\\\\\\\fichierSource.txt', SubFolder.Path & '\\\\\\\\copieFichier.txt'
'--------------------------------------------------------------------

Next SubFolder

If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If

End Sub


bonne journée
MichelXld

Message édité par: michelxld, à: 15/02/2006 10:49

 

[pobrouwers]

MichelXLD,

Encore Merci !!! Tu as réponse à tout, c'est magnifique.

Je vais adapter le code pour le choix du répertoire... et pour les check

Merci

 

[Blunet]

Rebonjour pobrouwers, MichelXld,

Je bloque depuis 1 moment sur Filecopy, en effet j'ai essayé d'écrire le code de copie d'un fichier à un emplacement 1 dans tous les sous répertoires d'un répertoire à un autre emplacement 2.

J'ai voulu joué au malin en créant simplement une collection d'objets répertoires, mais la routine Filecopy me pose unproblème d'accès auw fichiers. Voici le Code:

Sub Kopi()
Dim CheminSource, CheminDestination As String
CheminDestination = 'C:\\Documents and Settings\\xxx\\Mes documents\\Zw Alex'
CheminSource = 'C:\\Documents and Settings\\xxx\\Bureau\\Classeur2.xls'
Dim Fil, Fich, FichColl, FichSys, fl
Set FichSys = CreateObject('Scripting.FileSystemObject')
Set Fil = FichSys.GetFolder(CheminDestination)
Set FichColl = Fil.SubFolders
'Pour afficher les dossiers dans 1 Msgbox
For Each Fich In FichColl
fl = fl & Fich.Name
fl = fl & vbCrLf
Next
MsgBox fl
'Copie du fichier dans les sous répertoires
For Each Fich In FichColl
FileCopy CheminSource, CheminDestination
Next
End Sub

A défaut je me contenterais de l'exmple de Pascal

 

[Blunet]

Rebonjour pobrouwers, MichelXld,

Je bloque depuis 1 moment sur Filecopy, en effet j'ai essayé d'écrire le code de copie d'un fichier à un emplacement 1 dans tous les sous répertoires d'un répertoire à un autre emplacement 2.

J'ai voulu joué au malin en créant simplement une collection d'objets répertoires, mais la routine Filecopy me pose unproblème d'accès auw fichiers. Voici le Code:

Sub Kopi()
Dim CheminSource, CheminDestination As String
CheminDestination = 'C:\\Documents and Settings\\xxx\\Mes documents\\Zw Alex'
CheminSource = 'C:\\Documents and Settings\\xxx\\Bureau\\Classeur2.xls'
Dim Fil, Fich, FichColl, FichSys, fl
Set FichSys = CreateObject('Scripting.FileSystemObject')
Set Fil = FichSys.GetFolder(CheminDestination)
Set FichColl = Fil.SubFolders
'Pour afficher les dossiers dans 1 Msgbox
For Each Fich In FichColl
fl = fl & Fich.Name
fl = fl & vbCrLf
Next
MsgBox fl
'Copie du fichier dans les sous répertoires
For Each Fich In FichColl
FileCopy CheminSource, CheminDestination
Next
End Sub

A défaut je me contenterais de l'exmple de Pascal

 

[pobrouwers]

Rebonjour,

J'ai trouvé sur le forum ce code pour le 'browse folder' qui pour moi est plus simple que la solution de Pascal...
Est-possible de le modifier pour redescendre dan s l'arborescence jusqu'au fichier et non pas jusqu'au folder.

Function BrowsingFolder(TheDrive As Variant)
Dim ObjShell As Object, ObjFolder As Object
Dim TheMessage As String
Dim ThePath As String
    
TheMessage = 'Séléctionnez un répertoire et puis OK :'

Set ObjShell = CreateObject('Shell.Application')
Set ObjFolder = ObjShell.BrowseForFolder(&H0&, TheMessage, 1, TheDrive)
    
    On Error Resume Next 'Si on sort sans sélection
    ThePath = ObjFolder.ParentFolder.ParseName(ObjFolder.Title).Path & ''
    BrowsingFolder = ThePath
End Function

Merci

Message édité par: pobrouwers, à: 15/02/2006 19:37

 

[MichelXld]

bonjour Pobrouwers , bonjour Blunet

Est-possible de le modifier pour redescendre dan s l'arborescence jusqu'au fichier et non pas jusqu'au folder

Désolé mais je ne comprend pas : tu veux sélectionner un dossier ou un fichier ?

s'il s'agit de sélectionner un fichier tu peux par exemple utiliser la methode GetOpenFilename

fileToOpen = Application.GetOpenFilename('Text Files (*.txt), *.txt')
MsgBox fileToOpen


tu peux aussi utiliser la propriété fileDialog à partir d'XP

Sub selectionFichier_afficherChemin()
'à partir d'Excel2002
Dim Repertoire As FileDialog
Set Repertoire = Application.FileDialog(msoFileDialogFilePicker)
Repertoire.Show
MsgBox Repertoire.SelectedItems(1)
End Sub


bonne journée
MichelXld

Message édité par: michelxld, à: 16/02/2006 06:25

 

[pobrouwers]

Bonjour MichelXld, Blunet,

Dans le premier post, je voulais bien sélectionner le folder mais pour une autre application, j'ai besoin de récupérer le fichier, c'est pour ca que je posais la question et je n'allais pas ouvrir un nouveau post puisque ca traite de la meme chose.
Merci