austenr
11-08-2005, 01:32 PM
The below code works as is if you select something other than Desktop, however, nothing is selected if you select desktop in the browser window.
anyone have any ideas? Thanks
Sub Srch()
Dim i As Long, z As Long, ws As Worksheet, y As Variant
Dim fLdr As String
y = Application.InputBox("Please Enter File Extension", "Info Request")
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = BrowseForFolderShell
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error GoTo 1
2: ws.Name = "FileSearch Results"
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
If Left$(.FoundFiles(i), 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(.FoundFiles(i)))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 3) = _
Array(Dir(.FoundFiles(i)), _
FileLen(.FoundFiles(i)) \ 1000, , _
FileDateTime(.FoundFiles(i)))
ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
End If
End With
ActiveWindow.DisplayHeadings = False
With ws
With .[a1:c1 ]
.Value = [{"Full Name","Kilobytes","Last Modified"}]
.Font.Underline = xlUnderlineStyleSingle
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[d1:iv1 ].EntireColumn.Hidden = True
Range(.[a65536 ].End(3)(2), _
.[a65536 ]).EntireRow.Hidden = True
Range(.[a2 ], .[c65536 ]).Sort [a2 ], xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
Function BrowseForFolderShell() As String
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
' Uncomment next line to start at desktop
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, 0)
'***Specify Starting Browse Location
'Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, "c:\")
If (Not objFolder Is Nothing) Then
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then BrowseForFolderShell = CStr(objFolder): GoTo Here
On Error GoTo 0
If Len(objFolder.Items.Item.Path) > 3 Then
BrowseForFolderShell = objFolder.Items.Item.Path & _
Application.PathSeparator
Else
BrowseForFolderShell = objFolder.Items.Item.Path
End If
Else: Application.ScreenUpdating = True: End
End If
Here:
Set objFolder = Nothing: Set objShell = Nothing
End Function
anyone have any ideas? Thanks
Sub Srch()
Dim i As Long, z As Long, ws As Worksheet, y As Variant
Dim fLdr As String
y = Application.InputBox("Please Enter File Extension", "Info Request")
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = BrowseForFolderShell
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error GoTo 1
2: ws.Name = "FileSearch Results"
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
If Left$(.FoundFiles(i), 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(.FoundFiles(i)))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 3) = _
Array(Dir(.FoundFiles(i)), _
FileLen(.FoundFiles(i)) \ 1000, , _
FileDateTime(.FoundFiles(i)))
ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
End If
End With
ActiveWindow.DisplayHeadings = False
With ws
With .[a1:c1 ]
.Value = [{"Full Name","Kilobytes","Last Modified"}]
.Font.Underline = xlUnderlineStyleSingle
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[d1:iv1 ].EntireColumn.Hidden = True
Range(.[a65536 ].End(3)(2), _
.[a65536 ]).EntireRow.Hidden = True
Range(.[a2 ], .[c65536 ]).Sort [a2 ], xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
Function BrowseForFolderShell() As String
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
' Uncomment next line to start at desktop
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, 0)
'***Specify Starting Browse Location
'Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, "c:\")
If (Not objFolder Is Nothing) Then
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then BrowseForFolderShell = CStr(objFolder): GoTo Here
On Error GoTo 0
If Len(objFolder.Items.Item.Path) > 3 Then
BrowseForFolderShell = objFolder.Items.Item.Path & _
Application.PathSeparator
Else
BrowseForFolderShell = objFolder.Items.Item.Path
End If
Else: Application.ScreenUpdating = True: End
End If
Here:
Set objFolder = Nothing: Set objShell = Nothing
End Function