VBA access 利用树形图treeview 显示本地目录结构

2017-08-29 17:46:00
Jorden
转贴:
Jorden的博客
270

最近在做一个access数据库,要利用treeview控件,但是网上搜到的方法大多是基于文件结构表的,就是说你在使用之前必须维护一张和目录结构一致的树状结构表,但是这使得添加文件或者删除文件的时候就相当不方便,因此,经过大量尝试,终于得到一个利用DIR函数(使用方法参见msdn:http://msdn.microsoft.com/en-us/library/dk008ty4(v=VS.71)),直接从本地目录中得到结构信息,利用迭代的方法,添加到treeview中的节点中,但这种方法中有点缺陷,现在将代码贴出,和大家分享,也希望达人们能够帮助解决这个缺陷(见代码中用红色标出的部分):

窗口上放置一个Treeview,其名字为XTree,一个imglist,名字为imglist0,treeview和imglist关联

添加主窗体的加载事件:
Private Sub Form_Load()
On Error GoTo Err_Form_load
Dim path As String
path = CurrentProject.path
path = path & "\project_data"
Call LoadTree(xTree, path, "project_data")
Call ExpandAndShrink(3, xTree)
Exit_Form_load:
Exit Sub
Err_Form_load:
MsgBox Error
Resume Exit_Form_load
End Sub
其中调用的函数代码为:
'=================================================================================================
Function ExpandAndShrink(OptionMethod As Integer, objtree As Object)
Dim i As Integer
Select Case OptionMethod
Case 1 '展开
For i = 1 To objtree.Nodes.Count
objtree.Nodes(i).Expanded = True
Next i
Case 2 '收缩
For i = 1 To objtree.Nodes.Count
objtree.Nodes(i).Expanded = False
Next i
Case 3 '展开至二级目录
For i = 1 To objtree.Nodes.Count
objtree.Nodes(i).Expanded = False
Next i
objtree.Nodes(1).Expanded = True
End Select
End Function
'=================================================================================================
Private Function loadnodes(ByVal parentid As String, ByVal pathstr As String, ByVal objtree As Object)
On Error GoTo err_loadlist
'必须手动添加第一个基本节点,然后采用迭代的方法添加该目录下的其他文件或文件夹
'---------------------------------------------------------------------------------
Dim idstring As String
Dim myname As String
Dim index As Integer
Dim i As Integer
Dim nodCurrent As Node
pathstr = pathstr & ""
Dim nametmp As String
myname = Dir(pathstr, vbDirectory)
index = 1
Do While myname <> ""
If myname <> "." And myname <> ".." Then
If (GetAttr(pathstr & myname) And vbDirectory) = vbDirectory Then
Set nodCurrent = objtree.Nodes.Add(parentid, tvwChild, parentid & "." & index, myname, "K1", "K2")
Call loadnodes(parentid & "." & index, pathstr & myname, objtree)
'从递归返回后dir()就无法从断点处直接得到下一个条目
'此处采用重新寻找到断点之前的条目,然后指向下一个
'是否有更简单的方法????????
nametmp = myname
myname = Dir(pathstr, vbDirectory)
Do While myname <> nametmp
myname = Dir()
Loop
myname = Dir()
Else
Set nodCurrent = objtree.Nodes.Add(parentid, tvwChild, parentid & "." & index, myname, "K3", "K4")
myname = Dir()
End If
index = index + 1
Else
myname = Dir()
End If
Loop
'----------------------------------------------------------------------------------
exit_loadlist:
Exit Function
err_loadlist:
MsgBox Error
Resume exit_loadlist
End Function
'=================================================================================================
Function LoadTree(ByVal objtree As Object, ByVal rootpath As String, ByVal rootname As String)
On Error GoTo err_loadTree
'----------------------------------------------------------------------------
'treeview控件加载函数
'作者:zhudan zhudan_02@yahoo.cn
'objtree:必填,treeview控件名
'rootpath:需要展示的目录路径
'rootname:根目录的名字,可以不和根目录名相同
'需要调用函数:loadnodes,请一起包含该函数
'----------------------------------------------------------------------------
Dim nodCurrent As Node
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
objtree.Nodes.Clear
Set nodCurrent = objtree.Nodes.Add(, , "r", rootname, "K1", "K2")
Call loadnodes("r", rootpath, objtree)
Call ExpandAndShrink(3, objtree)
'----------------------------------------------------------------------------
exit_loadTree:
Exit Function
err_loadTree:
MsgBox Error
Resume exit_loadTree
End Function


其得到的结果:


    分享