Help needed from Tom Ogilvy
 

Dear Tom,
Can I add up a follow-up question here?.
Can I present an Input Box (+message box) just before the filtering criteria
and let the user decide what extention to search for (i.e...*.doc, *.mp3,
....*.zip etc) for crearting the list?.
TIA


"Tom Ogilvy" wrote in message
...
maybe here
Else
if Instr(1,file.name,".xls",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
End If

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Hi,
The below code successfully lists all files from the selected drive
(including all subfolders).
I need to modify it to list the "*.xls" files only. Can someone show me
how?.
TIA

Here goes...
==================
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 = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i + 2, 2),
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
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

Help needed from Tom Ogilvy
 

at the appropriate place in your code you could do

res = Inputbox("Please enter an extension to search for in the format
'.xls')
res = Trim(res)

then later in the code;

Else
if Instr(1,file.name,res,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
End If

You may want to add some checks to insure the user puts in a valid file
extension.

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Dear Tom,
Can I add up a follow-up question here?.
Can I present an Input Box (+message box) just before the filtering
criteria
and let the user decide what extention to search for (i.e...*.doc, *.mp3,
...*.zip etc) for crearting the list?.
TIA


"Tom Ogilvy" wrote in message
...
maybe here
Else
if Instr(1,file.name,".xls",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
End If

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Hi,
The below code successfully lists all files from the selected drive
(including all subfolders).
I need to modify it to list the "*.xls" files only. Can someone show
me
how?.
TIA

Here goes...
==================
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 = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i + 2,
2),
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
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

Help needed from Tom Ogilvy
 

Thank you so much Tom...

"Tom Ogilvy" wrote in message
...
at the appropriate place in your code you could do

res = Inputbox("Please enter an extension to search for in the format
'.xls')
res = Trim(res)

then later in the code;

Else
if Instr(1,file.name,res,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
End If

You may want to add some checks to insure the user puts in a valid file
extension.

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Dear Tom,
Can I add up a follow-up question here?.
Can I present an Input Box (+message box) just before the filtering
criteria
and let the user decide what extention to search for (i.e...*.doc,
*.mp3,
...*.zip etc) for crearting the list?.
TIA


"Tom Ogilvy" wrote in message
...
maybe here
Else
if Instr(1,file.name,".xls",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
End If

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Hi,
The below code successfully lists all files from the selected drive
(including all subfolders).
I need to modify it to list the "*.xls" files only. Can someone show
me
how?.
TIA

Here goes...
==================
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 = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i + 2,
2),
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
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

Help needed from Tom Ogilvy
 

Tom, I used your lines including variable res at appropriate places but
failed to get the list. Should the variable 'res' be defined as a String (as
I did) on the sheets page?. I tried defining the variable in the Workbook's
page too with no better result. I tried entering extensions such as '.txt',
'.bat',...etc (with no quotes) with no success.
the Inputbox keeps asking me the same Q. i think The code seems to crash
!...


"Tom Ogilvy" wrote in message
...
at the appropriate place in your code you could do

res = Inputbox("Please enter an extension to search for in the format
'.xls')
res = Trim(res)

then later in the code;

Else
if Instr(1,file.name,res,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
End If

You may want to add some checks to insure the user puts in a valid file
extension.

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Dear Tom,
Can I add up a follow-up question here?.
Can I present an Input Box (+message box) just before the filtering
criteria
and let the user decide what extention to search for (i.e...*.doc,
*.mp3,
...*.zip etc) for crearting the list?.
TIA


"Tom Ogilvy" wrote in message
...
maybe here
Else
if Instr(1,file.name,".xls",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
End If

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Hi,
The below code successfully lists all files from the selected drive
(including all subfolders).
I need to modify it to list the "*.xls" files only. Can someone show
me
how?.
TIA

Here goes...
==================
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 = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i + 2,
2),
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
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

Help needed from Tom Ogilvy
 

This worked for me:

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
Dim res As String

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
res = InputBox("Please enter an extension" & _
" to search for in the format'.xls'")
res = Trim(res)

arFiles(1, 0) = level
SelectFiles arFiles(0, 0)

Worksheets.Add.Name = "Files"
With ActiveSheet
.Cells(1, 1).Value = "Path"
.Cells(1, 2).Value = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add _
Anchor:=.Cells(i + 2, 2), _
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
If InStr(1, file.Name, res, 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
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


Again, you might do more checking on what the user puts in the input box.

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Tom, I used your lines including variable res at appropriate places but
failed to get the list. Should the variable 'res' be defined as a String
(as
I did) on the sheets page?. I tried defining the variable in the
Workbook's
page too with no better result. I tried entering extensions such as
'.txt',
'.bat',...etc (with no quotes) with no success.
the Inputbox keeps asking me the same Q. i think The code seems to crash
!...


"Tom Ogilvy" wrote in message
...
at the appropriate place in your code you could do

res = Inputbox("Please enter an extension to search for in the format
'.xls')
res = Trim(res)

then later in the code;

Else
if Instr(1,file.name,res,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
End If

You may want to add some checks to insure the user puts in a valid file
extension.

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Dear Tom,
Can I add up a follow-up question here?.
Can I present an Input Box (+message box) just before the filtering
criteria
and let the user decide what extention to search for (i.e...*.doc,
*.mp3,
...*.zip etc) for crearting the list?.
TIA


"Tom Ogilvy" wrote in message
...
maybe here
Else
if Instr(1,file.name,".xls",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
End If

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Hi,
The below code successfully lists all files from the selected
drive
(including all subfolders).
I need to modify it to list the "*.xls" files only. Can someone
show
me
how?.
TIA

Here goes...
==================
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 = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i +
2,
2),
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
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

Help needed from Tom Ogilvy
 

Tom,
Thank you for your reply.
Yes your code worked OK for me too...only with a small problem remaining. I
have a button on Sheet1 (which activates a codeline "Sheet1.Folders" to
start your macro code). When this button is pressed the selection of
drive/folder ..etc and then the input for the extension to be searched is
done. But your code presents me this input box before the button is pressed.
Can we overcome this?
Regards

"Tom Ogilvy" wrote in message
...
This worked for me:

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
Dim res As String

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
res = InputBox("Please enter an extension" & _
" to search for in the format'.xls'")
res = Trim(res)

arFiles(1, 0) = level
SelectFiles arFiles(0, 0)

Worksheets.Add.Name = "Files"
With ActiveSheet
.Cells(1, 1).Value = "Path"
.Cells(1, 2).Value = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add _
Anchor:=.Cells(i + 2, 2), _
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
If InStr(1, file.Name, res, 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
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


Again, you might do more checking on what the user puts in the input box.

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Tom, I used your lines including variable res at appropriate places but
failed to get the list. Should the variable 'res' be defined as a String
(as
I did) on the sheets page?. I tried defining the variable in the
Workbook's
page too with no better result. I tried entering extensions such as
'.txt',
'.bat',...etc (with no quotes) with no success.
the Inputbox keeps asking me the same Q. i think The code seems to crash
!...


"Tom Ogilvy" wrote in message
...
at the appropriate place in your code you could do

res = Inputbox("Please enter an extension to search for in the format
'.xls')
res = Trim(res)

then later in the code;

Else
if Instr(1,file.name,res,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
End If

You may want to add some checks to insure the user puts in a valid
file
extension.

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Dear Tom,
Can I add up a follow-up question here?.
Can I present an Input Box (+message box) just before the filtering
criteria
and let the user decide what extention to search for (i.e...*.doc,
*.mp3,
...*.zip etc) for crearting the list?.
TIA


"Tom Ogilvy" wrote in message
...
maybe here
Else
if Instr(1,file.name,".xls",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
End If

--
Regards,
Tom Ogilvy

"Jack" wrote in message
...
Hi,
The below code successfully lists all files from the selected
drive
(including all subfolders).
I need to modify it to list the "*.xls" files only. Can someone
show
me
how?.
TIA

Here goes...
==================
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 = "FileName"
.Cells(1, 3).Value = "Date"
.Cells(1, 4).Value = "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
' alttaki satýr badmin e ait.
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i
+
2,
2),
Address:=arFiles(0, i) & "\" & arFiles(1, i)
Next
.Columns("A:D").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 (file.Attributes And 2 Or _
file.Attributes And 4) Then
'
Else
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

















---
Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (http://www.grisoft.com).
Version: 6.0.764 / Virus Database: 511 - Release Date: 15.09.2004