自己动手写程序，想添加什么功能就添加什么，真是很爽。
因为我用的access数据库保存资料，在自动读入treeview控件中时，为了解决读入的先后顺序，我给每个记录添加了一个divid字段，比如根节点是0，一级是1，二级是2，依次类推，所以拖拽是必须考虑修改该字段，实现起来复杂了一些，现在我按照拖拽实现的顺序编程如下：
Private Sub TreeView1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
mybutton = Button
If Button = vbLeftButton And Shift Then
Set sourcenode = TreeView1.SelectedItem '设置拖动的源 对象，全局node对象
sourcedivid = txtdivid
Set TreeView1.DropHighlight = Nothing
'DropHighlight 返回或设置一个Node对象或ListItem对象的引用。该对象在鼠标移到其上时使用系统加亮颜色加亮。
End If
End Sub
Private Sub TreeView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
StatusBar1.Panels(1).Text = "请及时保存。"
If Button = vbLeftButton And Shift Then
dragnow = True
TreeView1.DragIcon = TreeView1.SelectedItem.CreateDragImage ‘定义拖拽显示的图标，必须的。
TreeView1.Drag vbBeginDrag ’开始
End If
End Sub
Private Sub TreeView1_DragOver(Source As Control, x As Single, y As Single, State As Integer)
If dragnow = True Then
' Set DropHighlight to the mouse's coordinates.
Set TreeView1.DropHighlight = TreeView1.HitTest(x, y) ‘注意既使目标高亮，又是设置目标对象
End If
End Sub
Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)’拖放后的目标操作
Dim parentkey As String
Dim parentdivid As Integer
Set mcctree = DataEnvironment1.rsCommand2
If TreeView1.DropHighlight Is Nothing Then '如果目标为空，不操作
dragnow = False
Exit Sub
Else ' Set dragged node's parent property to the target node.
On Error GoTo checkerror ' To prevent circular errors.
If MsgBox("你确定要把[" & sourcenode.Text & "]移动到[" & TreeView1.DropHighlight.Text & "]下吗？ ", vbOKCancel) = vbCancel Then Exit Sub
If TreeView1.DropHighlight.Text = "我的文档" Then '因为数据库里没有该记录，所以如果目标是放到根节点下，则需要单独处理
parentkey = "root"
parentdivid = 1
mcctree.find "title='" & sourcenode.Text & "'", , , adBookmarkFirst
mcctree.Fields("relative") = parentkey ’修改数据库
mcctree.Fields("divid") = parentdivid
mcctree.Update
Set sourcenode.Parent = TreeView1.DropHighlight ‘这里是修改treeview的节点位置的关键代码。 Else
mcctree.find "title='" & TreeView1.DropHighlight.Text & "'", , , adBookmarkFirst
If mcctree.Fields("key") = "" Then '如果目标不是节点，则放弃
MsgBox "非节点不能放置", vbInformation
Set mcctree = Nothing
Exit Sub
End If
‘如果既不是根节点也不是资料则如下处理
Set sourcenode.Parent = TreeView1.DropHighlight
mcctree.find "title='" & sourcenode.Parent.Text & "'", , , adBookmarkFirst ’查父节点
parentkey = mcctree.Fields("key").Value
parentdivid = mcctree.Fields("divid").Value
If CInt(txtdivid) + 1 = sourcedivid Then '如果是同级别，则只要改relative
mcctree.find "title='" & sourcenode.Text & "'", , , adBookmarkFirst
mcctree.Update "relative", parentkey
Debug.Print "ok111", parentkey
Else ‘否则要改relative 和divid两个字段的值
mcctree.find "title='" & sourcenode.Text & "'", , , adBookmarkFirst
Debug.Print parentkey, parentdivid + 1
mcctree.Fields("relative") = parentkey
mcctree.Fields("divid") = parentdivid + 1
mcctree.Update
updatechildnod mcctree.Fields("key").Value, mcctree.Fields("divid").Value ’递归子函数
End If
End If
Cls '清除
Set TreeView1.DropHighlight = Nothing
dragnow = False
Set mcctree = Nothing
Exit Sub ' Exit if no errors occured.
End If
checkerror: ' Define constants to represent Visual Basic errors code.
Const CircularError = 35614
If Err.Number = CircularError Then
Dim msg As String
msg = "A node can't be made a child of its own children."
If MsgBox(msg, vbExclamation & vbOKCancel) = vbOK Then
dragnow = False
Set TreeView1.DropHighlight = Nothing
Set mcctree = Nothing
Exit Sub
End If
Else
Set mcctree = Nothing
Debug.Print Err.Description
End If
Exit Sub
End Sub
Private Sub updatechildnod(nodekey As String, nodedivid As Integer) ‘递归子函数
Dim upcctree As ADODB.Recordset
Dim nkey() As String ’动态数组
Dim ndivid() As Integer
Dim i As Integer
Dim x As Integer
i = 0
If DataEnvironment1.rsCommand4.State = 1 Then ’因为每次都要关闭记录对象所以递归要变通。
DataEnvironment1.rsCommand4.Close
End If
DataEnvironment1.rsCommand4.Open "select * from cctree where [relative]= '" & nodekey & "'"
x = DataEnvironment1.rsCommand4.RecordCount ‘根据关键字查找子对象
If x > 0 Then
ReDim nkey(x) ’定义一个临时数组保存需要递归处理的字节点对象，
ReDim ndivid(x) ‘因为子节点对象不会超过符合条件的记录数，重定义数组
Set upcctree = DataEnvironment1.rsCommand4
upcctree.MoveFirst ‘到第一条
Do ’循环
Debug.Print upcctree.Fields("divid").Value, upcctree.Fields("title").Value
upcctree.Update "divid", nodedivid + 1 ‘子节点只要更新divid
If upcctree.Fields("key").Value <> "" Then
nkey(i) = upcctree.Fields("key").Value ’如果是子节点，暂时不处理，保存到数组中
ndivid(i) = upcctree.Fields("divid").Value
i = i + 1
End If
'Debug.Print upcctree.Fields("divid").Value, upcctree.Fields("title").Value
upcctree.MoveNext ‘继续处理下一条
Loop While Not upcctree.EOF ’这样本层节点下的所有对象都已修改，下面可以处理再下一级
If i <> 0 Then ‘判断是否有这样的节点
For x = 0 To i - 1
updatechildnod nkey(x), ndivid(x) ’递归
Next
End If
Set upcctree = Nothing
End If
End Sub
