作者：未知 来源：月光软件站 加入时间：2005-2-28　月光软件站

　　树形控件在大多数的系统中都会使用到。以其层次鲜明，操作简便的优点得到广大程序员以及使用人员的认可。不过，尽管树形控件操作比较简单，但是当与数据库结合的时候，操作会有一引起麻烦。

　　笔者将自己在实际应用过程中总结出来的代码编写成类，在以后使用的时候直接使用类就可以了。

　　　　　　　　　　　　　　　　　　　　　　　作者：崔占民

　　　　　　　　　　　　　　　　　　　　　EMAIL:[email protected]

代码如下：

首先，选择菜单－＞工程－＞添加类模块，输入以下代码：

Option Explicit

Private m_TreeView As TreeView

Public Sub CreateTreeView(aTreeView As Object)
    Set m_TreeView = aTreeView
End Sub

'添加数据到TREEVIEW控件
Public Sub AddTree(rs As Recordset, aID As String, aContext As String, aParentID As String)
    Dim Xnod As Node
   
    Do While Not rs.EOF
        If rs.Fields(aParentID) = 0 Then
            '加入根结点
            Set Xnod = m_TreeView.Nodes.Add(, , "key" & rs.Fields(aID), rs.Fields(aContext), 2)
        Else
            '加入子节点
            Set Xnod = m_TreeView.Nodes.Add("key" & rs.Fields(aParentID), tvwChild, "key" & rs.Fields(aID), rs.Fields(aContext), 1)
        End If
        Xnod.EnsureVisible
        rs.MoveNext
    Loop
End Sub

'取得所有子结点的关键字
Public Function GetSubNodeKey(aNode As Node) As String
    Dim StrWhere As String
   
    GetSubKey aNode, StrWhere
    If Len(StrWhere) > 0 Then
        GetSubNodeKey = "ID = " & Mid(aNode.Key, 4) & " OR " & Left(StrWhere, Len(StrWhere) - 4)
    Else
        GetSubNodeKey = "ID = " & Mid(aNode.Key, 4)
    End If
End Function

Public Sub GetSubKey(aNode As Node, aStrWhere As String)
    Dim NodeSub As Node

    Set NodeSub = aNode.Child
    While Not NodeSub Is Nothing
        aStrWhere = aStrWhere & "ID = " & Mid(NodeSub.Key, 4) & " OR "
        If NodeSub.Children > 0 Then GetSubKey NodeSub, aStrWhere
       
        Set NodeSub = NodeSub.Next
    Wend
End Sub

添加一窗口，为窗口添加一菜单，菜单项分别为：添加、修改、删除。菜单名分别为：mnuAdd、mnuModify、mnuDelete。

在窗口中添加一个TREEVIEW控件。

窗口代码如下：

Option Explicit

'工程--->引用--->Microsoft ActiveX Data Object 2.x Library（版本号）

Dim cn As ADODB.Connection
Dim m_bolAddFlag As Boolean
Dim m_strKey As String, m_strParentKey As String
Dim m_TreeOpt As New CTreeOpt

Private Sub Command1_Click()
    Dim rs As New ADODB.Recordset
   
    TreeView1.Nodes.Clear
    rs.Open "SELECT * FROM tbTree", cn, adOpenDynamic, adLockReadOnly
    m_TreeOpt.AddTree rs, "ID", "CONTEXT", "PARENTID"
    rs.Close
    Set rs = Nothing
End Sub

Private Sub Form_Load()
On Error GoTo Errhandle
    Set cn = New ADODB.Connection
    '连接数据库
    cn.ConnectionString = "DBQ=" & App.Path & "\db1.mdb;DefaultDir=" & _
        App.Path & ";Driver={Microsoft Access Driver (*.mdb)};" & _
        "DriverId=25;FIL=MS Access;ImplicitCommitSync=Yes;" & _
        "MaxBufferSize=512;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;" & _
        "Threads=3;UID=ADMIN;UserCommitSync=Yes;PWD=admind1234;"
    cn.Open
   
    m_TreeOpt.CreateTreeView TreeView1
    Command1.Value = True
   
    Exit Sub
Errhandle:
    MsgBox Err.Description, vbExclamation
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
    cn.Close
    Set cn = Nothing
    Set m_TreeOpt = Nothing
End Sub

'添加结点
Private Sub mnuAdd_Click()
    Dim rs As New ADODB.Recordset
   
    m_bolAddFlag = True
    If rs.State = adStateOpen Then rs.Close
    rs.Open "SELECT IIF (ISNULL (MAX(ID)), 1, MAX(ID)) AS ID_M FROM tbTree", cn, adOpenStatic, adLockReadOnly
    If rs.EOF Then
        m_strKey = "1"
    Else
        m_strKey = CStr(rs!ID_M + 1)
    End If
    With TreeView1
        m_strParentKey = .SelectedItem.Key
        .Nodes.Add(m_strParentKey, tvwChild, "key" & m_strKey, "新加结点", 1).Selected = True
        .StartLabelEdit
    End With
    rs.Close
    Set rs = Nothing
End Sub

'删除结点
Private Sub mnuDelete_Click()
    Dim StrWhere As String
   
    With TreeView1
        If .SelectedItem.Key = "key1" Then
            MsgBox "对不起,不能删除根点!", vbExclamation
            Exit Sub
        End If
        StrWhere = m_TreeOpt.GetSubNodeKey(.SelectedItem)
        cn.Execute "DELETE FROM tbTree WHERE " & StrWhere
        .Nodes.Remove .SelectedItem.Key
    End With
End Sub

'修改结点
Private Sub mnuModify_Click()
    m_bolAddFlag = False
   
    With TreeView1
        m_strKey = Mid(.SelectedItem.Key, 4)
        .StartLabelEdit
    End With
End Sub

Private Sub TreeView1_AfterLabelEdit(Cancel As Integer, NewString As String)
    cn.Execute "UPDATE tbTree SET CONTEXT = '" & NewString & "' WHERE ID = " & m_strKey
End Sub

Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer)
    If m_bolAddFlag Then
        Dim strSql As String
       
        m_strParentKey = Mid(m_strParentKey, 4)
        strSql = "INSERT INTO tbTree (ID, CONTEXT, PARENTID) VALUES (" & m_strKey & ", '新加结点', " & m_strParentKey & ")"
        cn.Execute strSql
    End If
End Sub

Private Sub TreeView1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton Then PopupMenu mnuPopup
End Sub

类里提供了将数据库中的数据显示在控件中的方法。删除结点及其下面所有子结点的方法。也可以将类做成DLL，在以后的应用中直接加载DLL就可以了。

相关软件：