Recherche fichier par extension et copie
igloo26
Messages postés
1
Date d'inscription
lundi 19 avril 2004
Statut
Membre
Dernière intervention
19 avril 2004
-
19 avril 2004 à 16:32
cs_CanisLupus Messages postés 3757 Date d'inscription mardi 23 septembre 2003 Statut Membre Dernière intervention 13 mars 2006 - 20 avril 2004 à 15:24
cs_CanisLupus Messages postés 3757 Date d'inscription mardi 23 septembre 2003 Statut Membre Dernière intervention 13 mars 2006 - 20 avril 2004 à 15:24
A voir également:
- Recherche fichier par extension et copie
- Fichier .ini - Conseils pratiques -Visual Basic / VB.NET
- Fichier class ✓ - Forum Java
- Extension .film ✓ - Forum Visual Basic 6
- Ouvrir un fichier java - Forum Java
- Lire informations fichier class dans un programme java ✓ - Forum Java
1 réponse
cs_CanisLupus
Messages postés
3757
Date d'inscription
mardi 23 septembre 2003
Statut
Membre
Dernière intervention
13 mars 2006
21
20 avril 2004 à 15:24
20 avril 2004 à 15:24
Salut,
Voilà un bout de code que g déjà utilisé et qui marche pour moi. Regarde si ça te convient.
'Sélectionner "Microsoft Scripting Runtime" dans Projet/Références
Dim fso As FileSystemObject
Dim cpt As Long ' pour le nombre de fichiers trouvés
Dim Tbl_FichierSource(500) As String ' Là g limité à 500 mais tu peux voir + grand
Dim Tbl_FichierDestination(500) As String ' ou jouer avec des redim dans le code
Dim Tbl_DossierReception(500) As String
Dim Dossier_Reception As String
Private Sub Rechercher_Fichiers(Dossier As String)
Dim fld As Folder
Dim subfld As Folder
Dim fl As File
' Set du dossier à parcourir
Set fld = fso.GetFolder(Dossier)
' Listage des fichiers du dossier sauf si c la corbeille
' ou le dossier de réception
If InStr(Dossier, "RECYCLED") = 0 And Left$(UCase(Dossier), Len(Dossier_Reception)) <> UCase(Dossier_Reception) Then
For Each fl In fld.Files
If LCase(Right(fl.Name, 3)) = "doc" Then
Tbl_FichierSource(cpt) = Dossier & fl.Name
Tbl_DossierReception(cpt) = Right(Dossier, Len(Dossier) - 3)
Tbl_FichierDestination(cpt) = fl.Name
cpt = cpt + 1
End If
Next
End If
' Recherche récursive des fichiers dans les sous-dossiers
For Each subfld In fld.SubFolders
Rechercher_Fichiers Dossier & subfld.Name & ""
Next
End Sub
Private Sub Form_Load()
Dim i As Long
Dim Dossier_Depart As String
Dim Dossier_Arrivee As String
Dim pos As Integer
Dim tmp_Dos As String
' Dossier de départ
Dossier_Depart = "C:"
Dossier_Reception = "c:\temp"
' Création du FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(Dossier_Reception) Then
fso.CreateFolder Dossier_Reception
End If
cpt = 0
' Rechercher les fichiers
Rechercher_Fichiers Dossier_Depart
' Copie des fichiers
For i = 0 To cpt - 1
Dossier_Arrivee = Dossier_Reception & Tbl_DossierReception(i)
If Not fso.FolderExists(Dossier_Arrivee) Then
tmp_Dos = Tbl_DossierReception(i)
Dossier_Arrivee = Dossier_Reception
Do While InStr(tmp_Dos, "") <> Len(tmp_Dos)
pos = InStr(tmp_Dos, "")
Dossier_Arrivee = Dossier_Arrivee & Left(tmp_Dos, pos)
If Not fso.FolderExists(Dossier_Arrivee) Then
fso.CreateFolder Dossier_Arrivee
End If
tmp_Dos = Right(tmp_Dos, Len(tmp_Dos) - pos)
Loop
fso.CreateFolder Dossier_Reception & Tbl_DossierReception(i)
End If
fso.CopyFile Tbl_FichierSource(i), Dossier_Arrivee & Tbl_FichierDestination(i), True
Next
MsgBox "C'est terminé !"
End Sub
Cordialement
CanisLupus
Voilà un bout de code que g déjà utilisé et qui marche pour moi. Regarde si ça te convient.
'Sélectionner "Microsoft Scripting Runtime" dans Projet/Références
Dim fso As FileSystemObject
Dim cpt As Long ' pour le nombre de fichiers trouvés
Dim Tbl_FichierSource(500) As String ' Là g limité à 500 mais tu peux voir + grand
Dim Tbl_FichierDestination(500) As String ' ou jouer avec des redim dans le code
Dim Tbl_DossierReception(500) As String
Dim Dossier_Reception As String
Private Sub Rechercher_Fichiers(Dossier As String)
Dim fld As Folder
Dim subfld As Folder
Dim fl As File
' Set du dossier à parcourir
Set fld = fso.GetFolder(Dossier)
' Listage des fichiers du dossier sauf si c la corbeille
' ou le dossier de réception
If InStr(Dossier, "RECYCLED") = 0 And Left$(UCase(Dossier), Len(Dossier_Reception)) <> UCase(Dossier_Reception) Then
For Each fl In fld.Files
If LCase(Right(fl.Name, 3)) = "doc" Then
Tbl_FichierSource(cpt) = Dossier & fl.Name
Tbl_DossierReception(cpt) = Right(Dossier, Len(Dossier) - 3)
Tbl_FichierDestination(cpt) = fl.Name
cpt = cpt + 1
End If
Next
End If
' Recherche récursive des fichiers dans les sous-dossiers
For Each subfld In fld.SubFolders
Rechercher_Fichiers Dossier & subfld.Name & ""
Next
End Sub
Private Sub Form_Load()
Dim i As Long
Dim Dossier_Depart As String
Dim Dossier_Arrivee As String
Dim pos As Integer
Dim tmp_Dos As String
' Dossier de départ
Dossier_Depart = "C:"
Dossier_Reception = "c:\temp"
' Création du FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(Dossier_Reception) Then
fso.CreateFolder Dossier_Reception
End If
cpt = 0
' Rechercher les fichiers
Rechercher_Fichiers Dossier_Depart
' Copie des fichiers
For i = 0 To cpt - 1
Dossier_Arrivee = Dossier_Reception & Tbl_DossierReception(i)
If Not fso.FolderExists(Dossier_Arrivee) Then
tmp_Dos = Tbl_DossierReception(i)
Dossier_Arrivee = Dossier_Reception
Do While InStr(tmp_Dos, "") <> Len(tmp_Dos)
pos = InStr(tmp_Dos, "")
Dossier_Arrivee = Dossier_Arrivee & Left(tmp_Dos, pos)
If Not fso.FolderExists(Dossier_Arrivee) Then
fso.CreateFolder Dossier_Arrivee
End If
tmp_Dos = Right(tmp_Dos, Len(tmp_Dos) - pos)
Loop
fso.CreateFolder Dossier_Reception & Tbl_DossierReception(i)
End If
fso.CopyFile Tbl_FichierSource(i), Dossier_Arrivee & Tbl_FichierDestination(i), True
Next
MsgBox "C'est terminé !"
End Sub
Cordialement
CanisLupus
