Liste de fichiers

Le
Tatanka
Bonjour,

Par macro, comment obtenir dans la plage A1:Ax le chemin complet
de tous les fichiers mp3 du lecteur D ?

Merci
Serge
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
michdenis
Le #23006331
Bonjour,

Une façon de faire ;-)


Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "kernel32" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante à définir*************

Const Masque = "*.mp3" 'Type Extension du fichier
Const NomFeuilleDestination = "Feuil1"
Const Repertoire = "D:" 'Le lecteur
Const Adr = "B5" 'Première cellule de la plage dans feuille

'********************************************

Sub test()
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Application.ScreenUpdating = False
With Worksheets(NomFeuilleDestination)
With .Range(Adr).Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort .Item(1, 1)
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindFile As Long
hFindFile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindFile, FileFindData
If FindNextFileA(hFindFile, FileFindData) = 0 Then
FindClose hFindFile
Exit Sub
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindFile, FileFindData)
FindClose hFindFile
End Sub



MichD
--------------------------------------------
"Tatanka" a écrit dans le message de groupe de discussion : igf2pp$n6s$

Bonjour,

Par macro, comment obtenir dans la plage A1:Ax le chemin complet
de tous les fichiers mp3 du lecteur D ?

Merci
Serge
isabelle
Le #23006511
bonjour Serge,

Sub MP3_Listing()
Dim sPath As String: sPath = GetShellFolder
If sPath = "" Then Exit Sub
If Dir(sPath, vbDirectory) = "" Then Exit Sub
Dim Headers(35), x%, y&, i&, p$, n$, oFile As Object
Dim objShell As Object, oFolder As Object
Set objShell = CreateObject("Shell.Application")
Set oFolder = objShell.Namespace(CStr(sPath))
Application.ScreenUpdating = False
'Workbooks.Add
For i = 0 To 34
Headers(i) = oFolder.GetDetailsOf(oFolder.Items, i)
Select Case i
Case 22, 18, 20, 33, 17, 4, 0, 9, 19, 10, 21 '0 To 50, si on veux tout lister
x = x + 1
Cells(1, 1) = "Répertoire"
Cells(1, x + 1) = Headers(i)
End Select
Next
y = 1
For Each oFile In oFolder.Items
p = oFile.Path: n = oFile.Name
x = 1: y = y + 1
For i = 0 To 34
Select Case i
Case 22, 18, 20, 33, 17, 4, 0, 9, 19, 10, 21 ' 0 To 50, si on veux tout lister
x = x + 1
Cells(y, 1) = sPath
Cells(y, x) = oFolder.GetDetailsOf(oFile, i)
With ActiveSheet
.Hyperlinks.Add .Range("B" & y), Hlink(p), , n, n
End With
End Select
Next
Next
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Font.Bold = True
Cells.Columns.AutoFit
Range("A1").Select
Set oFolder = Nothing: Set objShell = Nothing
End Sub
'-----------------------------------------
Private Function GetShellFolder() As String
Const Title = "Sélectionnez un répertoire !"
Dim oSHA As Object, oSF As Object, oItem As Object
On Error GoTo 1
Set oSHA = CreateObject("Shell.Application")
Set oSF = oSHA.BrowseForFolder(0, Title, &H1 Or &H10, &H11)
If InStr(TypeName(oSF), "Folder") <> 1 Then Exit Function
For Each oItem In oSF.parentfolder.Items
If oItem.Name = oSF.Title Then
GetShellFolder = oItem.Path
Exit Function
End If
Next
GetShellFolder = oSF.Title
Set oSF = Nothing: Set oSHA = Nothing
Exit Function
1: MsgBox "Error: " & Err.Number & vbLf & Err.Description, 48
End Function
'-----------------------------------------
Private Function Hlink(p As String) As String
Hlink = "file:///" & Replace(Replace(p, " ", "%20"), "", "/")
End Function

isabelle

Le 2011-01-10 08:50, Tatanka a écrit :
Bonjour,

Par macro, comment obtenir dans la plage A1:Ax le chemin complet
de tous les fichiers mp3 du lecteur D ?

Merci
Serge


Tatanka
Le #23007021
Ave Denis,

Quand je lance ta macro « test », j'obtiens toujours le message :
Aucun fichier n'ayant cette extenssion : *.mp3

Quelques éclaircissements :
http://cjoint.com/?3bkruWkvSy5

Serge
















On 10 jan, 09:10, "michdenis"
Bonjour,

Une fa on de faire  ;-)

Option Explicit

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * 260
  cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "kernel32" _
  (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Lo ng

Private Declare Function FindNextFileA Lib "kernel32" _
  (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" _
  (ByVal hFindFile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante d finir*************

Const Masque = "*.mp3"  'Type Extension du fichier
Const NomFeuilleDestination = "Feuil1"
Const Repertoire = "D:"  'Le lecteur
Const Adr = "B5"  'Premi re cellule de la plage dans feuille

'********************************************

Sub test()
If Dir(Repertoire, vbDirectory) <> "" Then
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ReDim Arr(1 To 1)
    NbFichiers = 0
    Recurse Repertoire
    If NbFichiers > 0 Then
        Application.ScreenUpdating = False
        With Worksheets(NomFeuilleDestination)
            With .Range(Adr).Resize(NbFichiers)
                .Value = Application.Transpose(Arr)
                .Sort .Item(1, 1)
                .EntireColumn.AutoFit
            End With
        End With
    Else
        MsgBox "Aucun fichier ayant cette extension : " & Masque
    End If
Else
    MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindFile As Long
hFindFile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindFile, FileFindData
If FindNextFileA(hFindFile, FileFindData) = 0 Then
    FindClose hFindFile
    Exit Sub
End If
Do
    Fichier = Chemin & Left$(FileFindData.cFileName, _
        InStr(1, FileFindData.cFileName, vbNullChar) - 1)
    If GetAttr(Fichier) And vbDirectory Then
        Recurse Fichier & ""
    ElseIf Fichier Like Masque Then
            NbFichiers = NbFichiers + 1
            ReDim Preserve Arr(1 To NbFichiers)
            Arr(NbFichiers) = Fichier
      End If
Loop While FindNextFileA(hFindFile, FileFindData)
FindClose hFindFile
End Sub

MichD
--------------------------------------------
"Tatanka"  a crit dans le message de groupe de discussion : igf2pp$n6..

Bonjour,

Par macro, comment obtenir dans la plage A1:Ax le chemin complet
de tous les fichiers mp3 du lecteur D ?

Merci
Serge
michdenis
Le #23007321
Je viens de la tester à nouveau, ça roule correctement !

As-tu adapter la valeur de ces constantes selon ton environnement ?

'************Constante à définir*************

Const Masque = "*.mp3" 'Type Extension du fichier
Const NomFeuilleDestination = "Feuil1"
Const Repertoire = "C:MonChemin" 'Le lecteur
Const Adr = "B5" 'Première cellule de la plage dans feuille

'********************************************

MichD
--------------------------------------------


"Tatanka" a écrit dans le message de groupe de discussion :


Ave Denis,

Quand je lance ta macro « test », j'obtiens toujours le message :
Aucun fichier n'ayant cette extenssion : *.mp3

Quelques éclaircissements :
http://cjoint.com/?3bkruWkvSy5

Serge
















On 10 jan, 09:10, "michdenis"
Bonjour,

Une fa on de faire ;-)

Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "kernel32" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante d finir*************

Const Masque = "*.mp3" 'Type Extension du fichier
Const NomFeuilleDestination = "Feuil1"
Const Repertoire = "D:" 'Le lecteur
Const Adr = "B5" 'Premi re cellule de la plage dans feuille

'********************************************

Sub test()
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Application.ScreenUpdating = False
With Worksheets(NomFeuilleDestination)
With .Range(Adr).Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort .Item(1, 1)
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindFile As Long
hFindFile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindFile, FileFindData
If FindNextFileA(hFindFile, FileFindData) = 0 Then
FindClose hFindFile
Exit Sub
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindFile, FileFindData)
FindClose hFindFile
End Sub

MichD
--------------------------------------------
"Tatanka" a crit dans le message de groupe de discussion : igf2pp$

Bonjour,

Par macro, comment obtenir dans la plage A1:Ax le chemin complet
de tous les fichiers mp3 du lecteur D ?

Merci
Serge
Tatanka
Le #23007391
C'est OK avec ceci :

Const Masque = "*.mp3"
Const NomFeuilleDestination = "Feuil1"
Const Repertoire = "D:Fonte et MP3"
Const Adr = "A5"

Je croyais que "D:" suffisait !

et j'ai ajouté :
Rows("1:4").Delete vers la fin de test.

Me voici pogné avec 4675 tounes de Metal sur ma feuille !!!

Merci, Merci,

Serge

On 10 jan, 14:34, "michdenis"
Je viens de la tester nouveau, a roule correctement !

As-tu adapter la valeur de ces constantes selon ton environnement ?

'************Constante d finir*************

Const Masque = "*.mp3"  'Type Extension du fichier
Const NomFeuilleDestination = "Feuil1"
Const Repertoire = "C:MonChemin"  'Le lecteur
Const Adr = "B5"  'Premi re cellule de la plage dans feuille

'********************************************

MichD
--------------------------------------------

"Tatanka"  a crit dans le message de groupe de discussion :


Ave Denis,

Quand je lance ta macro test , j'obtiens toujours le message :
Aucun fichier n'ayant cette extenssion : *.mp3

Quelques claircissements :http://cjoint.com/?3bkruWkvSy5

Serge

On 10 jan, 09:10, "michdenis"


> Bonjour,

> Une fa on de faire  ;-)

> Option Explicit

> Private Type FILETIME
>   dwLowDateTime As Long
>   dwHighDateTime As Long
> End Type

> Private Type WIN32_FIND_DATA
>   dwFileAttributes As Long
>   ftCreationTime As FILETIME
>   ftLastAccessTime As FILETIME
>   ftLastWriteTime As FILETIME
>   nFileSizeHigh As Long
>   nFileSizeLow As Long
>   dwReserved0 As Long
>   dwReserved1 As Long
>   cFileName As String * 260
>   cAlternate As String * 14
> End Type

> Private Declare Function FindFirstFileA Lib "kernel32" _
>   (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

> Private Declare Function FindNextFileA Lib "kernel32" _
>   (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Lon g

> Private Declare Function FindClose Lib "kernel32" _
>   (ByVal hFindFile As Long) As Long

> Dim Arr() As String
> Dim NbFichiers As Long
> Dim FileFindData As WIN32_FIND_DATA
> Dim Fichier As String
> Dim objFSO As Object, F As Object

> '************Constante d finir*************

> Const Masque = "*.mp3"  'Type Extension du fichier
> Const NomFeuilleDestination = "Feuil1"
> Const Repertoire = "D:"  'Le lecteur
> Const Adr = "B5"  'Premi re cellule de la plage dans feuille

> '********************************************

> Sub test()
> If Dir(Repertoire, vbDirectory) <> "" Then
>     Set objFSO = CreateObject("Scripting.FileSystemObject")
>     ReDim Arr(1 To 1)
>     NbFichiers = 0
>     Recurse Repertoire
>     If NbFichiers > 0 Then
>         Application.ScreenUpdating = False
>         With Worksheets(NomFeuilleDestination)
>             With .Range(Adr).Resize(NbFichiers)
>                 .Value = Application.Transpose(Arr)
>                 .Sort .Item(1, 1)
>                 .EntireColumn.AutoFit
>             End With
>         End With
>     Else
>         MsgBox "Aucun fichier ayant cette extension : " & Masqu e
>     End If
> Else
>     MsgBox "Chemin inexistant " & Repertoire
> End If
> Set objFSO = Nothing
> End Sub

> Private Sub Recurse(ByVal Chemin As String)
> Dim hFindFile As Long
> hFindFile = FindFirstFileA(Chemin & "*.*", FileFindData)
> FindNextFileA hFindFile, FileFindData
> If FindNextFileA(hFindFile, FileFindData) = 0 Then
>     FindClose hFindFile
>     Exit Sub
> End If
> Do
>     Fichier = Chemin & Left$(FileFindData.cFileName, _
>         InStr(1, FileFindData.cFileName, vbNullChar) - 1)
>     If GetAttr(Fichier) And vbDirectory Then
>         Recurse Fichier & ""
>     ElseIf Fichier Like Masque Then
>             NbFichiers = NbFichiers + 1
>             ReDim Preserve Arr(1 To NbFichiers)
>             Arr(NbFichiers) = Fichier
>       End If
> Loop While FindNextFileA(hFindFile, FileFindData)
> FindClose hFindFile
> End Sub

> MichD
> --------------------------------------------
> "Tatanka"  a crit dans le message de groupe de discussion : igf2pp$n6

> Bonjour,

> Par macro, comment obtenir dans la plage A1:Ax le chemin complet
> de tous les fichiers mp3 du lecteur D ?

> Merci
> Serge- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -
Publicité
Poster une réponse
Anonyme