'==================================================================================
'
' Dans environnement VBA
' Outils | Références COCHER Microsoft Scripting Runtime
'
' Sinon VBScript téléchargeable à
' http://msdn.microsoft.com/library/default.asp?url=/downloads/list/webdev.asp
'
'==================================================================================
Option Explicit
Dim NbFichiers As Long
Dim DossierOk As String
Const NomFichierRch = "Classeur*"
Const DossierRacine As String = "C:\Faq\FaqVba\Exemples"
Const NomFeuille As String = "Feuil1"
Const TypeFichier As String = "XLS"
Public Sub btnImport_QuandClic()
Dim Debut As Variant
Dim i As Long
Dim NomFichier As String
Dim NomDossier As String
Debut = Time()
Application.ScreenUpdating = False
NbFichiers = 0
DossierOk = BackSlashDossier(DossierRacine)
ListeFichiersDansDossier DossierOk, True
Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
Application.ScreenUpdating = True
End Sub
Private Function BackSlashDossier(ByVal TstDossier As String) As String
If Right(TstDossier, 1) <> "\" Then TstDossier = TstDossier & "\"
BackSlashDossier = TstDossier
End Function
Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim Extension As String
Dim r As Long, VerifNom As Boolean
On Error GoTo erreurs
Set FSO = New Scripting.FileSystemObject
Set DossierSource = FSO.GetFolder(NomDossierSource)
r = Range("A65536" ).End(xlUp).Row + 1
For Each Fichier In DossierSource.Files
Extension = UCase(FSO.GetExtensionName(Fichier))
VerifNom = Fichier.Name Like NomFichierRch
If Fichier.Name <> ThisWorkbook.Name Then
If VerifNom Then
If InStr(Fichier.Name, Chr(39)) > 0 Then Fichier.Name = Replace(Fichier.Name, Chr(39), "" )
If UCase(TypeFichier) = Extension Then
With ShImport ' Feuille recueillant les données
.Cells(r, 1)= Fichier.Name
.Cells(r, 2)= Fichier.ParentFolder
.Cells(r, 3)= Fichier.DateCreated
.Cells(r, 4)= Fichier.Size
NbFichiers = NbFichiers + 1
r = r + 1
End With
Application.StatusBar = "Lecture noms : " & r
End If
End If
End If
Next Fichier
If InclureSousDossiers Then
For Each SousDossier In DossierSource.SubFolders
ListeFichiersDansDossier SousDossier.Path, True
Next SousDossier
Set SousDossier = Nothing
End If
Set Fichier = Nothing
Set DossierSource = Nothing
Set FSO = Nothing
Exit Sub
erreurs:
Select Case Err.Number
Case 76
MsgBox "Dossier inexistant" & vbCrLf & "Modifier dans VBA le chemin" & vbCrLf & "Const Dossier = " & DossierRacine, vbOKOnly, "Dossier des Fichiers"
Case Else
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
End Select
End Sub
|
