MrExcel Publishing
Your One Stop for Excel Tips & Solutions

Get list of sub-directories


Posted by JAF on September 18, 2000 4:43 AM

Hi

I have some code (which I got from somewhare else - I dodn't write it!) which generates a list of files within a user specified directory (code at end of message).

This comes in very useful, but what I need now is something to generate a list of sub-directories (not file names) within a user specified directory.

I've tried mucking about with the above code, but it's beyond my level of VBA knowledge.

Any suggestions?
JAF


Code for generating list of files in a directory...
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public 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

Sub ListFiles()
Workbooks.Add
Msg = "Select a location containing the files you want to list."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
r = 1
' Insert headers
Cells.ClearContents
Cells(r, 1) = "FileName"
Cells(r, 2) = "Size"
Cells(r, 3) = "Date/Time"
Range("A1:C1").Font.Bold = True
r = r + 1
Columns("A:C").EntireColumn.AutoFit
Range("B1:C1").HorizontalAlignment = xlRight
' Get first file
On Error GoTo error_trap
f = Dir(Directory, 7)
Cells(r, 1) = f
Cells(r, 2) = FileLen(Directory & f)
Cells(r, 3) = FileDateTime(Directory & f)
' Get remaining files
Do While f <> ""
f = Dir
If f <> "" Then
r = r + 1
Cells(r, 1) = f
Cells(r, 2) = FileLen(Directory & f)
Cells(r, 3) = FileDateTime(Directory & f)
End If
Loop
Columns("A:C").EntireColumn.AutoFit
Range("B1:C1").HorizontalAlignment = xlRight
Exit Sub
error_trap:
MsgBox "No files in specified directory."
Exit Sub
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Posted by Celia on September 18, 0100 5:18 AM

JAF
See if the following does what you need. I didn't write it but don't have a record of where I got it from. I've never used it before now.
Celia

Sub List_Sub_Directories()
Dim dirList() As String
List_Directories "C:\My Documents\", dirList()
Print_List dirList()
End Sub
Sub List_Directories(anypath As String, dirList() As String)
Dim dirOutput As String, i%
dirOutput = Dir(anypath, vbDirectory)
Do While dirOutput <> ""
If dirOutput <> "." And dirOutput <> ".." Then
If (GetAttr(anypath & dirOutput) _
And vbDirectory) = vbDirectory Then
i = i + 1
ReDim Preserve dirList(1 To i)
dirList(i) = anypath & dirOutput
End If
End If
dirOutput = Dir()
Loop
End Sub
Sub Print_List(anyList() As String)
Dim i%, J%
For i = LBound(anyList) To UBound(anyList)
If LBound(anyList) = 0 Then J = 1
Cells(i + J, 1).Value = anyList(i)
Next
End Sub

Posted by Ivan Moala on September 18, 0100 10:29 AM

Hi Jaf
To combine Celias code (some alterations) and
the code you used......try this; This way will
give you the option of selecting the Dir to get
Via the Browsforfolder function.

'Code for generating list of files in a directory...
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public 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

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Sub List_Sub_Directories()
Dim dirList() As String
Dim Msg As String
Dim Directory As String

Msg = "Select a location containing the files you want to list."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"

List_Directories Directory, dirList()
Print_List dirList()

End Sub
Sub List_Directories(anypath As String, dirList() As String)
Dim dirOutput As String, i%
dirOutput = Dir(anypath, vbDirectory)

Do While dirOutput <> ""
If dirOutput <> "." And dirOutput <> ".." Then
If (GetAttr(anypath & dirOutput) And vbDirectory) = vbDirectory Then
i = i + 1
ReDim Preserve dirList(1 To i)
dirList(i) = anypath & dirOutput
End If
End If
dirOutput = Dir()
Loop

End Sub
Sub Print_List(anyList() As String)
Dim i As Integer
'Clear any previous text
Range(Cells(1, 1), Cells(1, 1).End(xlDown)).ClearContents
For i = LBound(anyList) To UBound(anyList)
Cells(i, 1).Value = anyList(i)
Next i
'Format
Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Columns.AutoFit

End Sub


Ivan