PDA

View Full Version : Solved: Browsing for folder shell



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

mvidas
11-08-2005, 01:42 PM
Hi Austen,

It looks like your function is returning "Desktop" when the desktop is selected. You could add the following function:Function DesktopAddress() As String
DesktopAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop")
End FunctionThen in your BrowseForFolderShell function, you could include this If line between Here: and when you set the objects to nothing:Here:
If BrowseForFolderShell = "Desktop" Then BrowseForFolderShell = DesktopAddress
Set objFolder = Nothing: Set objShell = NothingJust an idea
Matt

austenr
11-08-2005, 01:54 PM
Thanks Matt. Works great. Solved.

mvidas
11-08-2005, 02:16 PM
Glad to help!