Can we modify the macro to accept multi-inputs?

[J_J]

Hi,
I was not successfull trying to modify a macro code which tries to
accomplish a task similar to DOS DIR command....
The below code creates a page in the workbook listing all the *.mp3 files on
drive C: main directory & all sub directories. No problem so far. But I need
to modify the code in order to have the option of " multi selecting" the
extension of the files to be listed on seperate worksheets with the
extension name as their sheet names. For example if I input ".doc" AND
".xls" AND ".mp3" as extensions (can we do it all in one go? or must we do
this all in seperate steps?), the macro will create 3 worksheets with
worksheet names as "DOC", "XLS" and "MP3" including this type of files as
lists...
Can we achieve this?
TIA
J_J

Here goes the example
---------------------------

Option Explicit

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Dim FSO As Object
Dim cnt As Long
Dim level As Long
Dim arFiles

Sub Folders()
Dim i As Long

Set FSO = CreateObject("Scripting.FileSystemObject")

arFiles = Array()
cnt = 0
level = 1

ReDim arFiles(3, 0)
arFiles(0, 0) = GetFolder()
If arFiles(0, 0) <> "" Then
arFiles(1, 0) = level
SelectFiles arFiles(0, 0)

Worksheets.Add.Name = "Files"
With ActiveSheet
.Cells(1, 1).Value = "Path"
.Cells(1, 2).Value = "File Name"
.Cells(1, 3).Value = "Created"
.Cells(1, 4).Value = "File Size"
.Rows(1).Font.Bold = True
.Columns(4).NumberFormat = "#,##0 "" KB"""
cnt = 1
For i = LBound(arFiles, 2) To UBound(arFiles, 2)
.Cells(i + 2, 1).Value = arFiles(0, i)
.Cells(i + 2, 2).Value = arFiles(1, i)
.Cells(i + 2, 3).Value = arFiles(2, i)
.Cells(i + 2, 4).Value = arFiles(3, i) / 1024
'
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i + 2, 2),
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A").EntireColumn.AutoFit
End With
End If

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(ByVal sPath)
'-----------------------------------------------------------------------
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object

Set Folder = FSO.GetFolder(sPath)

Set Files = Folder.Files
For Each file In Files
If InStr(1, file.Name, ".mp3", vbTextCompare) > 0 Then
cnt = cnt + 1
ReDim Preserve arFiles(3, cnt)
arFiles(0, cnt) = Folder.path
arFiles(1, cnt) = file.Name
arFiles(2, cnt) = Format(file.DateCreated, "dd mmm yyyy")
arFiles(3, cnt) = file.Size
End If
Next file

level = level + 1
For Each fldr In Folder.Subfolders
SelectFiles fldr.path
Next

End Sub


'-------------------------------------------------------------
Function GetFolder(Optional ByVal Name As String = "Select a folder.")
As String
'-------------------------------------------------------------
Dim bInfo As BROWSEINFO
Dim path As String
Dim oDialog As Long

bInfo.pidlRoot = 0& '

bInfo.lpszTitle = Name

bInfo.ulFlags = &H1 '
oDialog = SHBrowseForFolder(bInfo) '

'
path = Space$(512)

GetFolder = ""
If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
GetFolder = Left(path, InStr(path, Chr$(0)) - 1)
End If

End Function

Private Sub CommandButton1_Click()
Sheet1.Folders
End Sub

 

[Bob Phillips]

We can.

Here is some modified code that will handle any number of file extensions. I
have used jpg and xls in my tests, but just change the fileTypes statement
early in the code

Option Explicit

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Dim FSO As Object
Dim cnt As Long
Dim level As Long
Dim cLastRow As Long
Dim arFiles
Dim fileTypes

Sub Folders()
Dim i As Long

Set FSO = CreateObject("Scripting.FileSystemObject")

fileTypes = [{"jpg","xls"}]

On Error Resume Next ' in case they already exist
For i = LBound(fileTypes) To UBound(fileTypes)
Worksheets.Add.Name = fileTypes(i)
With Worksheets(fileTypes(i))
.Cells.ClearContents
.Cells(1, 1).Value = "Path"
.Cells(1, 2).Value = "File Name"
.Cells(1, 3).Value = "Created"
.Cells(1, 4).Value = "File Size"
.Rows(1).Font.Bold = True
.Columns(4).NumberFormat = "#,##0 "" KB"""
End With
Next i
On Error GoTo 0

arFiles = Array()
cnt = 0
level = 1

ReDim arFiles(4, 0)
arFiles(0, 0) = GetFolder()
If arFiles(0, 0) <> "" Then
arFiles(1, 0) = level
SelectFiles arFiles(0, 0)

cnt = 1
For i = LBound(arFiles, 2) + 1 To UBound(arFiles, 2)
With Worksheets(arFiles(4, i))
cLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(cLastRow, 1).Value = arFiles(0, i)
.Cells(cLastRow, 2).Value = arFiles(1, i)
.Cells(cLastRow, 3).Value = arFiles(2, i)
.Cells(cLastRow, 4).Value = arFiles(3, i) / 1024
.Hyperlinks.Add _
Anchor:=.Cells(cLastRow, 2), _
Address:=arFiles(0, i) & "\" & arFiles(1, i)
End With
Next
For i = LBound(fileTypes) To UBound(fileTypes)
Worksheets(fileTypes(i)).Columns("A").EntireColumn.AutoFit
Next i
End If

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(ByVal sPath)
'-----------------------------------------------------------------------
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object
Dim i As Long

Set Folder = FSO.GetFolder(sPath)

Set Files = Folder.Files
For Each file In Files
For i = LBound(fileTypes) To UBound(fileTypes)
If InStr(1, file.Name, fileTypes(i), vbTextCompare) > 0 Then
cnt = cnt + 1
ReDim Preserve arFiles(4, cnt)
arFiles(0, cnt) = Folder.path
arFiles(1, cnt) = file.Name
arFiles(2, cnt) = Format(file.DateCreated, "dd mmm yyyy")
arFiles(3, cnt) = file.Size
arFiles(4, cnt) = fileTypes(i)
Exit For
End If
Next i
Next file

level = level + 1
For Each fldr In Folder.Subfolders
SelectFiles fldr.path
Next

End Sub


'-------------------------------------------------------------
Function GetFolder(Optional ByVal Name As String = "Select a folder.")
As String
'-------------------------------------------------------------
Dim bInfo As BROWSEINFO
Dim path As String
Dim oDialog As Long

bInfo.pidlRoot = 0& '

bInfo.lpszTitle = Name

bInfo.ulFlags = &H1 '
oDialog = SHBrowseForFolder(bInfo) '

'
path = Space$(512)

GetFolder = ""
If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
GetFolder = Left(path, InStr(path, Chr$(0)) - 1)
End If

End Function



--

HTH

RP
(remove nothere from the email address if mailing direct)