|
Re: Recursive Function + File searching to return path
"ph8" <ph8.1s5rz9_1121342789.4701@excelforum-nospam.com> wrote in message
news:ph8.1s5rz9_1121342789.4701@excelforum-nospam.com...
>
> Hey folks, I need a little help.
>
> First and foremost, does Excel VBA support recursive functions/subs?
> (IE: can I call a sub from within the same sub?)
Yes, no problem as long as you are careful to ensure exits and termination
(but that is recursion, not Excel or VBA).
> Second. Does VBA have a way to browse through file directories? I have
> a file Hierarchy, and what I would love is for Excel to start at the
> top and for every .xls file it finds, put it in a list in the
> spreadsheet calling the 'search' macro. It should return the path of
> the file name. Since these spreadsheets are nested within directories,
> which are within directories, which are within directories, etc...
Yes it does. I have done this sort of thing many times before.
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
Private FSO As Object
Private cnt As Long
Private arfiles
Private level As Long
Sub Folders()
Dim i As Long
Dim sFolder As String
Dim sh As Worksheet
Set FSO = CreateObject("Scripting.FileSystemObject")
arfiles = Array()
cnt = -1
level = 1
sFolder = GetFolder
ReDim arfiles(1, 0)
If sFolder <> "" Then
SelectFiles sFolder
On Error Resume Next
Set sh = Worksheets("Files")
On Error GoTo 0
If Not sh Is Nothing Then
sh.Cells.ClearContents
Else
Worksheets.Add.Name = "Files"
End If
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(1, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(0, i)
Next
.Columns("A:Z").EntireColumn.AutoFit
End With
End If
End Sub
'-----------------------------*------------------------------*------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------*------------------------------*------------
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object
If sPath = "" Then
Set FSO = CreateObject("Scripting.FileSystemObject")
sPath = GetFolder
End If
Set Folder = FSO.GetFolder(sPath)
Set Files = Folder.Files
For Each file In Files
cnt = cnt + 1
ReDim Preserve arfiles(1, cnt)
arfiles(0, cnt) = Folder.path & "\" & file.Name
arfiles(1, cnt) = level
Next file
level = level + 1
For Each fldr In Folder.Subfolders
SelectFiles fldr.path
Next
level = level - 1
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& 'Root folder = Desktop
bInfo.lpszTitle = Name
bInfo.ulFlags = &H1 'Type of directory to
oDialog = SHBrowseForFolder(bInfo) 'display the dialog
'Parse the result
path = Space$(512)
GetFolder = ""
If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
GetFolder = Left(path, InStr(path, Chr$(0)) - 1)
End If
End Function
|