VBA access 利用树形图treeview 显示本地目录结构 - 第三方Activex控件

最近在做一个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

其得到的结果：

联系人：	王先生
Email：	18449932@qq.com
QQ：	18449932
微博：	officecn01

联系人：

王先生

Email：

18449932@qq.com

QQ：

18449932

微博：

officecn01