Option Compare Database
Option Explicit
Private SourceNode As node '定??点?曳的源?点
Private TargetNode As node '定??点?曳的目??点
Private Sub Form_Load()
Call SetTree(Me.xTree.Object, "a0")
End Sub
Private Sub SetTree(ByVal tree As TreeView, ByVal Parentkey As String)
Dim id As Long, str As String
Dim rs As New ADODB.Recordset
Dim ssql As String
Dim i As Long
Dim node As node
str = Left(Parentkey, 1) '取父?点key的第一个字符
id = Val(Mid(Parentkey, 2)) '取父?点key中的ParentID?
If id = 0 Then
xTree.Nodes.Clear
Set node = xTree.Nodes.Add(, , Parentkey, "産品目録")
node.Expanded = True
End If
ssql = "select * from 3 WHERE ParentID = " & id
rs.Open ssql, CurrentProject.Connection, adOpenStatic, adLockReadOnly
For i = 1 To rs.RecordCount
str = Chr(Asc(str) + 1) '字母?增一位
Set node = tree.Nodes.Add(Parentkey, tvwChild, str & rs!id.Value, rs!Name.Value)
Call SetTree(tree, str & rs!id.Value)
rs.MoveNext
Next
rs.Close: Set rs = Nothing
Set node = Nothing
End Sub
Private Sub xTree_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Long, ByVal y As Long)
Set SourceNode = Me.xTree.HitTest(x, y)
If SourceNode Is Nothing = False Then
If Button = 1 Then
Set Me.xTree.SelectedItem = SourceNode
End If
End If
End Sub
Private Sub xTree_OLEDragOver(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
Dim target As node
Set target = Me.xTree.HitTest(x, y)
If target Is TargetNode Then Exit Sub
If target Is Nothing Then Exit Sub
If target Is SourceNode Then Exit Sub
If isEldershipNode(SourceNode, target) Then Exit Sub
Set TargetNode = target
Set Me.xTree.DropHighlight = TargetNode
End Sub
Private Function isEldershipNode(NodeA As node, NodeB As node) As Boolean
'功能：判断NodeA是否?NodeB的前??点
If NodeB.Parent Is Nothing Then
isEldershipNode = False '如果?点B?根?点，那??点A不是?点B的前??点
ElseIf NodeB.Parent.Key = NodeA.Key Then
isEldershipNode = True
Else
isEldershipNode = isEldershipNode(NodeA, NodeB.Parent) '???用
End If
End Function
Private Sub xTree_OLEDragDrop(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim ssql As String
If Me.xTree.DropHighlight Is Nothing = False Then
ssql = "update tblType set ParentID=" & Val(Mid(TargetNode.Key, 2))
ssql = ssql & " where ID=" & Val(Mid(SourceNode.Key, 2))
CurrentDb.Execute ssql
Call SetTree(Me.xTree.Object, "a0")
End If
End Sub
代码这样
是不是代码那里有错误？
