Help needed from Tom Ogilvy

  • Thread starter Thread starter Jack
  • Start date Start date
J

Jack

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
 
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.
 
Thank you so much Tom...

Tom Ogilvy said:
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.
Click to expand...
 
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
!...
 
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.
 
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
 
Back
Top