pedritoteo
XLDnaute Nouveau
Bonjour à tous,
J'aimerais savoir comment changer ce code pour qu'il fonctionne sous Excel 2010 ?
merci pour vos réponses
salutations
Option Explicit
'____________________________________________________________
'
'Written by Andrew Fergus 10 September 2007
'____________________________________________________________
Public RowCount As Long
'SET THE DRIVE / FOLDER TO SEARCH HERE
Const MyStartFolder As String = "E:\MyMusicFiles\Music"
'SET THE WORKSHEET NAME TO HOLD THE RESULTS HERE
Const MyOutputSheet2 As String = "Sheet2"
Public Sub GetMyListOfMusic()
RowCount = 1
With Application.FileSearch
.NewSearch
.LookIn = MyStartFolder
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
.Execute
If .FoundFiles.Count > 0 Then
GetMySongs (MyStartFolder)
Else
MsgBox "There were no files in that directory!", vbCritical, "Error"
End If
End With
MsgBox "Finished creating file list!", vbInformation, "Done!"
End Sub
Sub GetMySongs(TargetDir As Variant)
Dim objShell As Object
Dim objFolder As Object
Dim strFileName As Variant
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(TargetDir)
For Each strFileName In objFolder.Items
If objFolder.GetDetailsOf(strFileName, 2) = "File Folder" Then
GetMySongs (TargetDir & "\" & objFolder.GetDetailsOf(strFileName, 0))
Else
RowCount = RowCount + 1
With Worksheets(MyOutputSheet2)
'File Name
.Cells(RowCount, 1) = objFolder.GetDetailsOf(strFileName, 0)
'Location
.Cells(RowCount, 2) = TargetDir
'Artist
.Cells(RowCount, 3) = objFolder.GetDetailsOf(strFileName, 16)
'Album
.Cells(RowCount, 4) = objFolder.GetDetailsOf(strFileName, 17)
'Year
.Cells(RowCount, 5) = objFolder.GetDetailsOf(strFileName, 18)
'Genre
.Cells(RowCount, 6) = objFolder.GetDetailsOf(strFileName, 20)
'Track number
.Cells(RowCount, 7) = objFolder.GetDetailsOf(strFileName, 19)
'Format
.Cells(RowCount, 8) = objFolder.GetDetailsOf(strFileName, 2)
End With
End If
Next
Set objShell = Nothing
Set objFolder = Nothing
End Sub
J'aimerais savoir comment changer ce code pour qu'il fonctionne sous Excel 2010 ?
merci pour vos réponses
salutations
Option Explicit
'____________________________________________________________
'
'Written by Andrew Fergus 10 September 2007
'____________________________________________________________
Public RowCount As Long
'SET THE DRIVE / FOLDER TO SEARCH HERE
Const MyStartFolder As String = "E:\MyMusicFiles\Music"
'SET THE WORKSHEET NAME TO HOLD THE RESULTS HERE
Const MyOutputSheet2 As String = "Sheet2"
Public Sub GetMyListOfMusic()
RowCount = 1
With Application.FileSearch
.NewSearch
.LookIn = MyStartFolder
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
.Execute
If .FoundFiles.Count > 0 Then
GetMySongs (MyStartFolder)
Else
MsgBox "There were no files in that directory!", vbCritical, "Error"
End If
End With
MsgBox "Finished creating file list!", vbInformation, "Done!"
End Sub
Sub GetMySongs(TargetDir As Variant)
Dim objShell As Object
Dim objFolder As Object
Dim strFileName As Variant
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(TargetDir)
For Each strFileName In objFolder.Items
If objFolder.GetDetailsOf(strFileName, 2) = "File Folder" Then
GetMySongs (TargetDir & "\" & objFolder.GetDetailsOf(strFileName, 0))
Else
RowCount = RowCount + 1
With Worksheets(MyOutputSheet2)
'File Name
.Cells(RowCount, 1) = objFolder.GetDetailsOf(strFileName, 0)
'Location
.Cells(RowCount, 2) = TargetDir
'Artist
.Cells(RowCount, 3) = objFolder.GetDetailsOf(strFileName, 16)
'Album
.Cells(RowCount, 4) = objFolder.GetDetailsOf(strFileName, 17)
'Year
.Cells(RowCount, 5) = objFolder.GetDetailsOf(strFileName, 18)
'Genre
.Cells(RowCount, 6) = objFolder.GetDetailsOf(strFileName, 20)
'Track number
.Cells(RowCount, 7) = objFolder.GetDetailsOf(strFileName, 19)
'Format
.Cells(RowCount, 8) = objFolder.GetDetailsOf(strFileName, 2)
End With
End If
Next
Set objShell = Nothing
Set objFolder = Nothing
End Sub