近期在做仓库管理软件时，需要用到Treeview树形菜单，需要对treeview菜单增加，删除及移动操作，并实时更新保存到access数据库中。

http://s6/mw690/001lsXE5zy6Qldxekdvd5&690

（动画录制不太好，将就一下！）

主要步骤：

1、程序界面及组件

http://s3/mw690/001lsXE5zy6Qlddvmxke2&690

程序源代码：

Option Explicit
Dim Nodx As Node
Dim mbIndrag As Boolean
Dim moDragNode As Object
Dim SSS As String '数据库表中该记录的PARENT 在其之后，所有记录ID集

Private Sub Command1_Click() '添加子节点
    Dim skey As String
    Dim iIndex As Integer
    Dim T As String
    On Error GoTo myerr
    iIndex = TreeView1.SelectedItem.Index
    T = InputBox("请输入子节点text", "请输入....", "请输入节点的名称")
    Call ADD(TreeView1.Nodes(iIndex).Key, T, 1, 2)
    Exit Sub
myerr:
   MsgBox ("请选择要添加的父节点")
    Exit Sub
End Sub

Private Sub Command2_Click()
Dim i As Integer
  For i = 1 To TreeView1.Nodes.Count
    TreeView1.Nodes(i).Expanded = True '展开所有节点
  Next i
End Sub

Private Sub Command3_Click()
Dim i As Integer
  For i = 1 To TreeView1.Nodes.Count
    TreeView1.Nodes(i).Expanded = False '折叠所有节点
  Next i
End Sub

Private Sub Command4_Click() '删除节点
    Dim iIndex As Integer
    On Error GoTo myerr
    iIndex = TreeView1.SelectedItem.Index '选择的节点
    If MsgBox("确定删除当前选中的节点：" + TreeView1.Nodes(iIndex).Text, vbOKCancel + vbDefaultButton2 + vbExclamation, "信息提示") = vbOK Then
        If CZ(Trim(TreeView1.Nodes(iIndex).Key)) Then
            MsgBox "当前节点有下级，不能删除！", vbExclamation, "信息提示"
        Else
             Call DELL(Trim(TreeView1.Nodes(iIndex).Key))
             TreeView1.Nodes.Remove iIndex
        End If
    End If

    Exit Sub
myerr:
    MsgBox ("请选择要删除的节点" & "")
    Exit Sub
End Sub

Private Sub Command5_Click()
    Dim skey As String
    Dim iIndex As Integer
    Dim T As String
    Dim P As String
    Dim k As String
    On Error GoTo myerr
    iIndex = TreeView1.SelectedItem.Index
    k = TreeView1.Nodes(iIndex).Key
    Dim sql As String
    sql = "select * from List where KEY='" & k & "'"
    open_database
    rst.Open sql, cnn, 1, 3
    If rst.EOF = False Then
        P = rst.Fields("PARENT")
    End If
    close_database

    T = InputBox("请输入增加节点的名称", "请输入....", "请输入节点的名称")
    Call ADD(P, T, 1, 2)
    Exit Sub
myerr:
   MsgBox ("请选择要添加的父节点") + vbCrLf + "窗口加载出现错误！" + Err.Description + vbCrLf + Str(Err.Number), vbOKOnly, "温馨提示"
    Exit Sub
End Sub

Private Sub Form_Load()
On Error Resume Next
On Error GoTo errmsg
    TreeView1.LineStyle = tvwTreeLines '在兄弟节点和父节点之间显示线
    TreeView1.ImageList = ImageList1 '链接图像列
    TreeView1.Style = tvwTreelinesPlusMinusPictureText '树状外观包含全部元素
    SSS = "-"
    If Load_Node Then
        Do
             Call LOAD_Next
        Loop While (LOAD_Next)
    End If
    Exit Sub
errmsg:
    MsgBox "窗口加载出现错误！" + Err.Description + vbCrLf + Str(Err.Number), vbOKOnly, "温馨提示"
End Sub

Function ADD(P As String, T As String, i As Integer, J As Integer) As String
On Error GoTo errmsg
    Dim oNodex As Node
    open_database
    Dim sql As String
    sql = "select * from List"
    rst.Open sql, cnn, 1, 3
    rst.AddNew
    ADD = rst.Fields("ID")
    rst.Fields("KEY") = ADD & "_"
    rst.Fields("PARENT") = P
    rst.Fields("TEXT") = T
    rst.Fields("IMAGE") = i
    rst.Fields("S_IMAGE") = J
    rst.Update
    close_database
    If P = "0_" Then
        Set oNodex = TreeView1.Nodes.ADD(, , ADD & "_", T, i, J) '添加到控件中
    Else
        Set oNodex = TreeView1.Nodes.ADD(P, tvwChild, ADD & "_", T, i, J) '添加到控件中
    End If
    oNodex.EnsureVisible '刷新控件
    Exit Function
errmsg:
    MsgBox "窗口加载出现错误！" & vbCrLf & Err.Description, vbOKOnly, "温馨提示"
End Function

Private Sub TreeView1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Set TreeView1.DropHighlight = TreeView1.HitTest(x, y)
    If Not TreeView1.DropHighlight Is Nothing Then
        TreeView1.SelectedItem = TreeView1.HitTest(x, y)
        Set moDragNode = TreeView1.SelectedItem
    End If
    Set TreeView1.DropHighlight = Nothing
End Sub

Private Sub TreeView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
        mbIndrag = True
        TreeView1.DragIcon = TreeView1.SelectedItem.CreateDragImage '设置拖移的图标为选中node图标
        TreeView1.Drag vbBeginDrag ' 拖移操作
    End If
End Sub

Function DELL(k As String) '删除节点函数
    On Error GoTo errmsg
    open_database
    Dim sql As String
    sql = "select * from List where KEY='" & k & "'"
    rst.Open sql, cnn, 1, 3
    If rst.EOF = False Then
    rst.Delete
    rst.Update
    End If
    close_database
    Exit Function
errmsg:
    MsgBox "窗口加载出现错误！" & vbCrLf & Err.Description, vbOKOnly, "温馨提示"
End Function
Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
    If TreeView1.DropHighlight Is Nothing Then  '如果用户没有移动鼠标或释放在无效区域。
        mbIndrag = False
        Exit Sub
    Else
        '设置移动节点到目标节点的属性。
        'MsgBox moDragNode.Key
        If moDragNode.Key = TreeView1.DropHighlight.Key Then Exit Sub
        On Error GoTo checkerror
        Set moDragNode.Parent = TreeView1.DropHighlight '移动节点的父节点为突出颜色突出点中的对象
        'Cls
        Call moveN(Trim(moDragNode.Key), Trim(TreeView1.DropHighlight.Key))
        Set TreeView1.DropHighlight = Nothing
        mbIndrag = False
        Set moDragNode = Nothing
        Exit Sub
    End If
 
checkerror:
    Const CircularError = 35614

    If Err.Number = CircularError Then
        Dim msg As String
        msg = "错误！当前节点不可作为自己的子节点或子节点的子节点"
        If MsgBox(msg, vbExclamation & vbOKCancel, "错误") = vbOK Then
            ' 释放高亮对象
            mbIndrag = False
            Set TreeView1.DropHighlight = Nothing
            Exit Sub
        End If
    End If

End Sub

Private Sub TreeView1_DragOver(Source As Control, x As Single, y As Single, State As Integer)
    If mbIndrag = True Then
        Set TreeView1.DropHighlight = TreeView1.HitTest(x, y)
    End If
End Sub
Public Function moveN(k As String, Parent As String)

    On Error GoTo errmsg
    open_database
    Dim sql As String
    sql = "select * from List where KEY='" & k & "'"
    rst.Open sql, cnn, 1, 3
    If rst.EOF = False Then
        rst.Fields("PARENT") = Parent
        rst.Update
    End If
    close_database
    Exit Function
errmsg:
    MsgBox "窗口加载出现错误！" & vbCrLf & Err.Description, vbOKOnly, "温馨提示"

End Function

Public Function Load_Node() As Boolean '初步加载父节点及所有父节点存在的子节点
    On Error GoTo errmsg
    Load_Node = False
    open_database
    Dim sql As String
    sql = "select * from List"
    rst.Open sql, cnn, 1, 3
    If rst.BOF = False Then
        Do While (rst.EOF = False)
            If rst.Fields("PARENT") = "0_" Then
                Set Nodx = TreeView1.Nodes.ADD(, , rst.Fields("KEY"), rst.Fields("TEXT"), 1, 2)
                SSS = SSS & rst.Fields("ID") & "-"
            Else
                If (Val(Replace(rst.Fields("KEY"), "-", "")) > Val(Replace(rst.Fields("PARENT"), "_", ""))) And (InStr(SSS, "-" & Replace(rst.Fields("PARENT"), "_", "") & "-")) Then
                    Set Nodx = TreeView1.Nodes.ADD(Trim(rst.Fields("PARENT")), tvwChild, rst.Fields("KEY"), rst.Fields("TEXT"), 1, 2)
                    rst.Fields("A") = 0
                    SSS = SSS & rst.Fields("ID") & "-"
                Else
                    rst.Fields("A") = 1
                    Load_Node = True
                End If
            End If
            rst.MoveNext
        Loop
    End If
    close_database
    Exit Function
errmsg:
    MsgBox "窗口加载出现错误！1" & vbCrLf & Err.Description, vbOKOnly, "温馨提示"

End Function

Function LOAD_Next() '对先前没有加载的记录进行加载，非常重要
On Error GoTo errmsg
    open_database
    Dim sql As String
    sql = "select * from List where A = 1"
    rst.Open sql, cnn, 1, 3
    If rst.BOF = False Then
        Do While (rst.EOF = False)
                If InStr(SSS, "-" & Replace(rst.Fields("PARENT"), "_", "") & "-") Then
                    Set Nodx = TreeView1.Nodes.ADD(Trim(rst.Fields("PARENT")), tvwChild, rst.Fields("KEY"), rst.Fields("TEXT"), 1, 2)
                    rst.Fields("A") = 0
                    SSS = SSS & rst.Fields("ID") & "-"
                Else
                    rst.Fields("A") = 1
                    LOAD_Next = True
                End If           '
            rst.MoveNext
        Loop
    Else
        LOAD_Next = False
    End If
    close_database
    Exit Function
errmsg:
    MsgBox "窗口加载出现错误！2" & vbCrLf & Err.Description, vbOKOnly, "温馨提示"
End Function
Function CZ(k As String) As Boolean '查找是否有子节点
On Error GoTo errmsg
    open_database
    Dim sql As String
    sql = "select * from List where PARENT='" & k & "'"
    rst.Open sql, cnn, 1, 3
    If rst.EOF = False Then
        CZ = True
    End If
    close_database
    Exit Function
errmsg:
    MsgBox "窗口加载出现错误！2" & vbCrLf & Err.Description, vbOKOnly, "温馨提示"
End Function


由于牵扯到节点的移动和数据库更新，代码稍显累赘！

程序及源码下载请前往资源管理站自行下载！