'====================================================================== '功能: 查找指定文件夹含子文件夹内所有文件名或文件夹名(含路径) '函数名: getAllSubDirs '参数1: ThisDirPath 需查找的文件夹名,最后可以有或没有"\" '参数2: Files 是否只要文件夹名,可省略,默认为:FALSE '参数3: FileFilter 过滤文件文件名,可适用于like支持形式 '返回值: 一个Variant型的数组 '======================================================================= Function getAllSubDirs(ByVal ThisDirPath As String, _ Optional ByVal Files As Boolean = False, _ Optional ByVal FileFilter As String = "*.*") As Variant() '======代码开始============== Dim arr(), arrFileFullNames() 'arr为存储文件夹数组,arrFileFullNames存储文件数组 Dim DirName, thePath As String 'DirName为当前查询文件夹或文件,thePath为当前查询文件夹路径,ThisDirPath为指定查询的最上层文件夹路径 Dim i, j, k, m As Integer ThisDirPath = ThisDirPath & IIf(Right(ThisDirPath, 1) = "\", "", "\") '把指定最上层文件夹路径处理成"\"结尾路径 i = 0: j = 0: k = 0: m = 0 ReDim Preserve arr(j) arr(j) = ThisDirPath Do While j < UBound(arr) + 1 thePath = arr(j) DirName = Dir(thePath, vbDirectory) Do While DirName <> "" If DirName <> "." And DirName <> ".." Then If (GetAttr(thePath & DirName) And vbDirectory) = vbDirectory Then '如果是次级目录 i = i + 1 ReDim Preserve arr(i) arr(i) = thePath & DirName & "\" ElseIf thePath <> ThisDirPath And (DirName Like FileFilter) Then '如果非本工作簿所在文件夹文件,则文件全名存入数组 ReDim Preserve arrFileFullNames(k) arrFileFullNames(k) = thePath & DirName k = k + 1 End If End If DirName = Dir Loop j = j + 1 Loop '==========声明一个数组arrDirs接收arr数组除首个元素外数据(首个元素为指定文件夹本身)===== If i > 0 And Not Files Then 'i为0则没有下层文件夹 ReDim arrDirs(0 To UBound(arr) - 1) For m = 1 To UBound(arr) arrDirs(m - 1) = arr(m) Next Erase arr Erase arrFileFullNames getAllSubDirs = arrDirs ElseIf k > 0 And Files Then 'k为0则下层文件夹没有文件 Erase arrDirs Erase arr getAllSubDirs = arrFileFullNames Else arr(0) = "" getAllSubDirs = arr(0) End If End Function '======================================================================================================= '函数: getFileNameFromFullName 根据文件带全路径全名获得文件名 '参数1: strFullName 文件全名 '参数2: ifExName true 返回字符串含扩展名,默认是:False '参数3: strSplitor 各级文件夹分隔符 '作用: 从带路径文件全名径获取返回: 文件名(true带扩展名) '======================================================================================================= Public Function getFileNameFromFullName(ByVal strFullName As String, _ Optional ByVal ifExName As Boolean = False, _ Optional ByVal strSplitor As String = "\") As String '=======代码开始============================================================================== Dim ParentPath As String Dim FileName As String ParentPath = Left$(strFullName, InStrRev(strFullName, strSplitor, , vbTextCompare)) '反向查找路径分隔符,获取文件父级目录 FileName = Replace(strFullName, ParentPath, "") '替换父级目录为空得到文件名 If ifExName = False Then getFileNameFromFullName = Left(FileName, InStrRev(FileName, ".") - 1) '返回不带扩展名文件名 Else getFileNameFromFullName = FileName '返回带扩展名文件名 End If End Function '======================================================================================================= Function isEmptyArr(ByRef arr()) As Boolean '判断是否为空数组 Dim tempStr As String tempStr = Join(arr, ",") isEmptyArr = LenB(tempStr) <= 0 End Function
测试代码:
Sub test() Dim arr() Dim mypath As String mypath = ThisWorkbook.Path arr = getAllSubDirs(mypath, True, "*.xls") If isEmptyArr(arr) Then MsgBox "路径无效,退出程序!" Exit Sub End If Range("a1").Resize(UBound(arr) + 1, 1) = Application.Transpose(arr) End Sub