VBA access 利用樹形圖treeview 顯示本地目錄結構

2017-08-29 17:46:00
Jorden
轉貼:
Jorden的博客
5563

最近在做一個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 [email protected]
'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


其得到的結果:


    分享
    北京十一选五基本走势