Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Help needed from Tom Ogilvy
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel,microsoft.public.excel.programming
external usenet poster
  
Posts: 23
Default 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









Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel,microsoft.public.excel.programming
external usenet poster
  
Posts: 27,285
Default 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











Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel,microsoft.public.excel.programming
external usenet poster
  
Posts: 23
Default 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













Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel,microsoft.public.excel.programming
external usenet poster
  
Posts: 23
Default 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













Reply With QuoteReply With Quote
  #5   Report Post  
Posted to microsoft.public.excel,microsoft.public.excel.programming
external usenet poster
  
Posts: 27,285
Default 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















Reply With QuoteReply With Quote
  #6   Report Post  
Posted to microsoft.public.excel,microsoft.public.excel.programming
external usenet poster
  
Posts: 23
Default 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


Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Tom Ogilvy Denny Crane Excel Worksheet Functions 2 March 15th 06 08:41 PM
Thank You Tom Ogilvy Brian Excel Worksheet Functions 0 December 16th 04 02:47 AM
Thank u Tom Ogilvy helmekki[_19_] Excel Programming 0 August 7th 04 04:31 PM
Tom Ogilvy David Joseph Excel Programming 0 April 21st 04 02:57 PM
Help Tom Ogilvy [email protected] Excel Programming 9 January 18th 04 11:18 PM


All times are GMT +1. The time now is 06:50 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement