[已解决]求当前文件夹名和文件名显示在TreeView目录树代码

wsq7668

当前文件夹内有若干个子文件夹，每个子文件夹内有不等个文件，求各位大侠赐VB代码，把文件夹内的子文件夹名显示在一级目录里，打开一级目录，显示每个文件夹内指定格式的文件名

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-2-4 19:42

改了下。

1. Option Explicit
   
2. 
   
3. Private Sub CommandButton1_Click()
   
4.     Dim Path$
   
5.     Me.TreeView1.Visible = False
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .AllowMultiSelect = False
   
8.         .InitialFileName = ThisWorkbook.Path
   
9.         .Show
   
10.         If .SelectedItems.Count = 1 Then Path = .SelectedItems(1)
    
11.     End With
    
12.     If Len(Path) Then
    
13.         With Me.TreeView1
    
14.             .Visible = False
    
15.             .Nodes.Clear
    
16.             .ImageList = Me.ImageList1
    
17.             Call ListDir(Path)
    
18.             .Visible = True
    
19.         End With
    
20.     End If
    
21. End Sub
    
22. 
    
23. Sub ListDir(ByVal Path As String)
    
24.     Dim filename$, root As Node
    
25.     Dim arrPath()
    
26.     Dim sPath$
    
27.     Dim i&, j&
    
28.     i = 1
    
29.     j = 1
    
30.    
    
31.     ReDim arrPath(1 To 1)
    
32.     arrPath(i) = Path & Application.PathSeparator
    
33.     'On Error Resume Next
    
34.    
    
35.     With Me.TreeView1
    
36.         sPath = arrPath(j)
    
37.         Debug.Print sPath
    
38.         Set root = .Nodes.Add(, , sPath, sPath, 1)
    
39.         Do While Len(sPath)
    
40.             filename = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
41.             Do While Len(filename)
    
42.                
    
43.                 If Not (filename = "." Or filename = "..") Then
    
44.                     If (GetAttr(sPath & "" & filename) And vbDirectory) = 16 Then
    
45.                         '避免读取错误
    
46.                         If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
47.                         .Nodes.Add sPath, 4, sPath & filename & Application.PathSeparator, filename, 1
    
48.                         i = i + 1
    
49.                         ReDim Preserve arrPath(1 To i)
    
50.                         arrPath(i) = sPath & filename & Application.PathSeparator
    
51.                     Else
    
52.                         .Nodes.Add sPath, 4, sPath & filename, filename, 2
    
53.                     End If
    
54.                 End If
    
55. End1If:
    
56.                 filename = Dir
    
57.             Loop
    
58.             j = j + 1
    
59.             If j > i Then Exit Do
    
60.             sPath = arrPath(j)
    
61.         Loop
    
62.     End With
    
63. End Sub
    
64. 
    
65. Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer)
    
66.     Cancel = True
    
67. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

遍历文件夹，要是开太多会吃不开的。

wsq7668

就2到3级目录，请指点

hwc2ycy

Treeview.rar (45.31 KB, 下载次数: 78)

2013-2-4 19:43 上传

点击文件名下载附件
提取了一层，呆会再弄。

wsq7668

hwc2ycy 谢谢了！

wsq7668

麻烦您在附件里写下代码好吗！谢谢！

hwc2ycy

代码一直就有呀。
Treeview.rar (42.11 KB, 下载次数: 74)

2013-2-3 17:25 上传

点击文件名下载附件
改了点，对于读取失败的直接跳过了。

wsq7668

十分感谢，辛苦了！我试下代码

hwc2ycy

Treeview.rar (43.5 KB, 下载次数: 182)

2013-2-3 19:18 上传

点击文件名下载附件
理论上是多少导都行，但是搜多了，程序会响应不过来。
测试三层没问题。

wsq7668

麻烦您吧代码贴出来，我还是2003版本的，下了老半天兼容程序，网速慢！