如何自动将d盘中所有excel工作簿的路径写入到ListBox中
请教各位大神,如何自动将d盘中所有excel工作簿的路径写入到ListBox中
Private Sub Command1_Click() File1.Pattern = "*.xls;*.xlsx" '文件名过滤器,在这个处理设置,或者在初始化之前设置 List1.Clear '调用前,先清原来的数据 Call 递归目录("D:\") '调用,要传一个初始路径进去,可以不为根目录 End Sub Private Sub Dir1_Change() File1.Path = Dir1.Path '当目录路径改变时,修改文件框路径 End Sub Public Sub 递归目录(p As String) Dim i As Long '循环变量 Dim j As Long '当前子目录数 ,0-j Dim s() As String '缓存子目录名 Dir1.Path = p j = Dir1.ListCount - 1 '子目录数 If j >= 0 Then '有子目录,则继续递归调用 ReDim s(Dir1.ListCount - 1) For i = 0 To j '先缓存目录名,因为是重复使用这个控件 s(i) = Dir1.List(i) Next i For i = 0 To j '使用缓存的内容来递归调用 Call 递归目录(s(i)) Next i End If End Sub Private Sub File1_PathChange() '路径改变后会自动刷新文件列表,到这里处理 Dim i As Long Dim p As String p = File1.Path If Right(p, 1) <> "\" Then p = p & "\" '确保路径结尾正确 For i = 0 To File1.ListCount - 1 List1.AddItem p & File1.List(i) '添加到列表中 Next i End Sub
Private Sub Command2_Click() List1.Clear '调用前,先清原来的数据 Call 递归目录2("D:\","*.xls;*.xlsx") '调用,要传一个初始路径进去,可以不为根目录 End Sub Public Sub 递归目录2(P As String, Pattern As String) On Error Resume Next Dim i As Long, j As Long Dim s() As String Dim s1 As String Dim s2() As String If Right(P, 1) <> "\" Then P = P & "\" '缓存目录 j = 0 s1 = Dir(P, vbDirectory) Do While s1 <> "" If s1 <> "." And s1 <> ".." Then If (GetAttr(P & s1) And vbDirectory) = vbDirectory Then j = j + 1 ReDim Preserve s(j) s(j) = P & s1 End If End If s1 = Dir() Loop s2 = Split(Pattern, ";") For i = 0 To UBound(s2) Call 递归目录2列文件(P, s2(i)) 'DIR函数每个文件后缀需要单独使用,这个不方便。 Next i For i = 1 To j '递归调用自己,遍类目录 Call 递归目录2(s(i), Pattern) Next i End Sub Public Sub 递归目录2列文件(P As String, f As String) Dim s1 As String s1 = Dir(P & f) Do While s1 <> "" List1.AddItem P & s1 s1 = Dir() Loop End Sub