近期在做仓库管理软件时，需要用到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
InputBox("请输入子节点text", "请输入....", "请输入节点的名称")
ADD(TreeView1.Nodes(iIndex).Key, T, 1, 2)
myerr:
MsgBox ("请选择要添加的父节点")
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 '选择的节点
MsgBox("确定删除当前选中的节点：" + TreeView1.Nodes(iIndex).Text, vbOKCancel + vbDefaultButton2 + vbExclamation, "信息提示") = vbOK Then
If CZ(Trim(TreeView1.Nodes(iIndex).Key)) Then
MsgBox "当前节点有下级，不能删除！", vbExclamation, "信息提示"
Call DELL(Trim(TreeView1.Nodes(iIndex).Key))
TreeView1.Nodes.Remove iIndex
End If
End If

myerr:
MsgBox ("请选择要删除的节点" & "")
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
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

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

Private Sub Form_Load()
On Error Resume Next
On Error GoTo errmsg
TreeView1.LineStyle = tvwTreeLines '在兄弟节点和父节点之间显示线
TreeView1.ImageList = ImageList1 '链接图像列
TreeView1.Style = tvwTreelinesPlusMinusPic tureText '树状外观包含全部元素
SSS = If Load_Node Call LOAD_Next
Loop While (LOAD_Next)
End If
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_" Set oNodex = TreeView1.Nodes.ADD(, , ADD & "_", T, i, J) '添加到控件中
Set oNodex = TreeView1.Nodes.ADD(P, tvwChild, ADD & "_", T, i, J) '添加到控件中
End If
oNodex.EnsureVisible '刷新控件
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)
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
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
Function
errmsg:
MsgBox "窗口加载出现错误！" & vbCrLf & Err.Description, vbOKOnly, "温馨提示"
End Function
Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
TreeView1.DropHighlight Is Nothing Then '如果用户没有移动鼠标或释放在无效区域。
mbIndrag = False
Exit Sub
'设置移动节点到目标节点的属性。
'MsgBox moDragNode.Key
If moDragNode.Key = TreeView1.DropHighlight.Key Then Exit Sub
On Error GoTo checkerror
Set moDragNode.Parent = TreeView1.DropHighlight '移动节点的父节点为突出颜色突出点中的对象
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

Err.Number = CircularError Then
Dim msg As String
msg = "错误！当前节点不可作为自己的子节点或子节点的子节点"
If MsgBox(msg, vbExclamation & vbOKCancel, "错误") = vbOK ' 释放高亮对象
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
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") & "-"
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") & "-"
rst.Fields("A") = 1
Load_Node = True