Get Sub Directories using VBA Dir Function The
below function is used to get the immediate sub-directories for a given
directory. If you want to dig deep into the directory structure then
you need to iterate the sub-directories as well
Sub Get_All_SubDirectories()
Dim arSubDir() As String
Dim sSubDir As String
sSubDir = GetSubDir("d:\trash\")
' -----------------------------------------------------------
' Coded by Shasur for
http://vbadud.blogspot.com' -----------------------------------------------------------
If LenB(sSubDir) <> 0 Then
arSubDir = Split(sSubDir, ";")
For i1 = 0 To UBound(arSubDir)
Debug.Print arSubDir(i1)
Next i1
End If
End Sub
Function GetSubDir(ByVal sPath As String, Optional ByVal sPattern As Variant) As Variant
Dim sDir As String
Dim sDirLocationForText As String
On Error GoTo Err_Clk
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
If IsMissing(sPattern) Then
sDir = Dir$(sPath, vbDirectory)
Else
sDir = Dir$(sPath & sPattern, vbDirectory)
End If
' -----------------------------------------------------------
' Coded by Shasur for
http://vbadud.blogspot.com' -----------------------------------------------------------
Do Until LenB(sDir) = 0
' -----------------------------------------------------
' This will be the location for the sub directory
' -----------------------------------------------------
If sDir <> "." And sDir <> ".." Then
sDirLocationForText = sDirLocationForText & ";" & sPath & sDir
End If
sDir = Dir$
Loop
If Left$(sDirLocationForText, 1) = ";" Then sDirLocationForText = Right(sDirLocationForText, Len(sDirLocationForText) - 1)
GetSubDir = sDirLocationForText
Err_Clk:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Function