Find all subfolders with the name "X"

How can I find all subfolder with the name of "X" within a given directory?? I've seen code for finding files, but not folders.

Thanks in advance!
~ Matt W

 

Are you familiar with the File System object?

JR

directory?? I've seen code for finding files, but not folders.

 

A little... how can I get just the folder(s) that I'm looking for though?

TIA
~ Matt W

 

'one primitive way using vb's dir function
'a very basic starting point
'you could rewrite to make it a function that accepts directory name to
start in

Sub ShowFolders()
Dim mypath As String
Dim myname As String
' Display the names in C:\ that represent directories.
mypath = "c:\" ' Set the path to your desired path.
myname = Dir(mypath, vbDirectory) ' Retrieve the first entry.
Do While myname <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If myname <> "." And myname <> ".." Then
' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(mypath & myname) And vbDirectory) = vbDirectory Then
'''''********* Here test the name against your desired name - if
it matches - do whatever'''''*********
Debug.Print myname ' Display entry only if it represents a
directory.
End If
End If
myname = Dir ' Get next entry.
Loop
End Sub

you can also use winapi instead of dir function



Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

'declare winapi functions

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA"
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias
"GetFileAttributesA" (ByVal lpFileName As String) As Long

Public Sub CollectFolders(ByVal sPath As String, ByVal bRecurse As Boolean,
ByRef colFolderNames As Collection)
'modified by mark - original by KPD-Team 1999
'E-Mail:
'URL: http://www.allapi.net/
Dim sFullpath As String ' Walking pathname variable...
Dim FileName As String ' Walking filename variable...
Dim DirName As String ' SubDirectory Name
Dim dirNames() As String ' Buffer for directory name entries
Dim nDir As Integer ' Number of directories in this path
Dim i As Integer ' For-loop counter...
Dim hSearch As Long ' Search Handle
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer

If sPath = "" Then
Exit Sub
End If

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
' Search for subdirectories.
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(sPath & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = StripNulls(WFD.cFileName)
' Ignore the current and encompassing directories.
If (DirName <> ".") And (DirName <> "..") Then
' Check for directory with bitwise comparison.
If GetFileAttributes(sPath & DirName) And
FILE_ATTRIBUTE_DIRECTORY Then
sFullpath = sPath
AddDirectory sFullpath, DirName

'''*** here test name against desired name before putting in colletion if
you wish*******

colFolderNames.Add sFullpath
If bRecurse = True Then
CollectFolders sFullpath, True, colFolderNames
End If
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
End If
Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
Loop
Cont = FindClose(hSearch)
End If
End Sub

Public Sub AddDirectory(ByRef sInPath As String, ByVal sInDirToAdd As
String)
Dim sErrMsg As String
'if empty string passed in as path arg, assume dirtoadd is drive letter
If sInPath = "" Then
If Len(sInDirToAdd) = 1 Then 'if only the letter is supplied, add colon
sInPath = sInDirToAdd & ":\"
Else 'if len is 2 and colon is present
If Len(sInDirToAdd) = 2 And Mid$(sInDirToAdd, Len(sInDirToAdd)) = ":"
Then

sInPath = sInDirToAdd & "\" 'put drive designation in path variable
Else
sErrMsg = "Invalid drive specifiction in AddDirectory sub"
MsgBox sErrMsg

End If
End If
Else 'inPath is not blank so we're adding to a directory listing
If Mid$(sInPath, Len(sInPath)) = "\" Then
sInPath = sInPath & sInDirToAdd
Else
sInPath = sInPath & "\" & sInDirToAdd
End If
End If
End Sub

 

The following uses the Microsoft Scripting Runtime
---------------------------------------------------------------------------
Option Explicit
Option Compare Text

Public Sub FindFolder()
Call GetAllFolders("C:\Temp")
End Sub

Private Sub GetAllFolders(strPath As String)
Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objSubDirs As Scripting.Folders
Dim objLoopFolder As Scripting.Folder
Set objFSO = New Scripting.FileSystemObject
Set objFolder = objFSO.GetFolder(strPath)
If objFolder.Name = "X" Then
    Debug.Print objFolder.Path
End If
Set objSubDirs = objFolder.SubFolders
For Each objLoopFolder In objSubDirs
    Call GetAllFolders(objLoopFolder.Path)
Next objLoopFolder
End Sub