Liste de fichiers

michdenis

10/01/2011 à 15:10

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

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$1@speranza.aioe.org...

Bonjour,

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

Merci
Serge

Vous avez filtré cet utilisateur ! Consultez son message

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

10/01/2011 à 16:19

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

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

Vous avez filtré cet utilisateur ! Consultez son message

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

10/01/2011 à 19:03

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" wrote:

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

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" <michde...@hotmail.com> wrote:

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.. .@speranza.aioe.org...

Bonjour,

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

Merci
Serge

Vous avez filtré cet utilisateur ! Consultez son message

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" wrote:

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

10/01/2011 à 20:34

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" wrote:

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

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 :
4d453c46-ea96-45ec-a035-e6f614601965@p7g2000prb.googlegroups.com...

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" <michde...@hotmail.com> wrote:

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$n6...@speranza.aioe.org...

Bonjour,

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

Merci
Serge

Vous avez filtré cet utilisateur ! Consultez son message

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" wrote:

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

10/01/2011 à 21:11

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" wrote:

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" wrote:

> 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 -

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" <michde...@hotmail.com> wrote:

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 :
4d453c46-ea96-45ec-a035-e6f614601...@p7g2000prb.googlegroups.com...

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" <michde...@hotmail.com> wrote:

> 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 ...@speranza.aioe.org...

> 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 -

Vous avez filtré cet utilisateur ! Consultez son message

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" wrote:

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" wrote:

> 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 -

Liste de fichiers

5 réponses

Veuillez sélectionner un problème