1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
| '==================================================================
'This procedure populates the TreeView control when the form opens.
'==================================================================
Private Sub Form_Load()
On Error GoTo ErrForm_Load
Dim db As Database
Dim rst As Recordset
Dim nodCurrent As Node, nodRoot As Node
Dim objTree As TreeView
Dim strText As String, bk As String
Set db = CurrentDb
'Open the Employees table.
Set rst = db.OpenRecordset("Employees", dbOpenDynaset, dbReadOnly)
'Create a reference to the TreeView Control.
Set objTree = Me!Xtree.Object
'Find the first employee who is a supervisor.
rst.FindFirst "[ReportsTo] Is Null"
'Build the TreeView list of supervisors and their employees.
Do Until rst.NoMatch
'Extract the supervisor's name.
strText = rst![LastName] & (", " + rst![FirstName])
'Add a root level node to the tree for the supervisor.
Set nodCurrent = objTree.Nodes.Add(, , "a" & rst!EmployeeID, _
strText)
'Use a placeholder to save this place in the recordset.
bk = rst.Bookmark
'Run a recursive procedure to add all the child nodes
'for employees who report to this supervisor.
AddChildren nodCurrent, rst
'Return to your placeholder.
rst.Bookmark = bk
'Find the next supervisor.
rst.FindNext "[ReportsTo] Is Null"
Loop
ExitForm_Load:
Exit Sub
ErrForm_Load:
MsgBox Err.Description, vbCritical, "Form_Load"
Resume ExitForm_Load
End Sub
'===================================================================
'This procedure adds child nodes to the tree for all employees who
'report to a particular supervisor, and calls itself recursively
'to add child nodes for all other employees they supervise.
'
'Note that this procedure accepts the open Employees recordset by
'reference so you do not have to open a new recordset for each call.
'===================================================================
Sub AddChildren(nodBoss As Node, rst As Recordset)
On Error GoTo ErrAddChildren
Dim nodCurrent As Node
Dim objTree As TreeView
Dim strText As String, bk As String
'Create a reference to the TreeView control.
Set objTree = Me!Xtree.Object
'Find the first employee who reports to the supervisor for this node.
rst.FindFirst "[ReportsTo] =" & Mid(nodBoss.Key, 2)
'Build the list of employees who report to this supervisor.
Do Until rst.NoMatch
'Extract the employee's name.
strText = rst![LastName] & (", " + rst![FirstName])
'Add as a child node to the tree.
Set nodCurrent = objTree.Nodes.Add(nodBoss, tvwChild, "a" & _
rst!EmployeeID, strText)
'Save your place in the recordset.
bk = rst.Bookmark
'Add any employees for whom the current node is a supervisor.
AddChildren nodCurrent, rst
'Return to your place in the recordset and continue to search.
rst.Bookmark = bk
'Find the next employee who reports to this supervisor.
rst.FindNext "[ReportsTo]=" & Mid(nodBoss.Key, 2)
Loop
ExitAddChildren:
Exit Sub
ErrAddChildren:
MsgBox "Can't add child: " & Err.Description, vbCritical, _
"AddChildren(nodBoss As Node) Error:"
Resume ExitAddChildren
End Sub
'==================================================================
'This procedure in the OLEStartDrag event of the TreeView control
'clears the selected node so you can choose a new one.
'==================================================================
Private Sub xTree_OLEStartDrag(Data As Object, AllowedEffects As _
Long)
Me!Xtree.Object.SelectedItem = Nothing
End Sub
'====================================================================
'Use the OLEDragOver event of the TreeView control to select the
'node to drag, and to highlight the target nodes where the drop will
'occur when you release the mouse. This procedure sets the selected
'node to drag once. After that, if a node is already selected, the
'procedure assumes it was set during an earlier call in the dragging
'process and it does not reset it. The second half of this procedure
'highlights the node you are dragging over.
'====================================================================
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 oTree As TreeView
'Create a reference to the TreeView control.
Set oTree = Me!Xtree.Object
'If no node is selected, select the first node you dragged over.
If oTree.SelectedItem Is Nothing Then
Set oTree.SelectedItem = oTree.HitTest(x, y)
End If
'Highlight the node being dragged over as a potential drop target.
Set oTree.DropHighlight = oTree.HitTest(x, y)
End Sub
'==================================================================
'The OLEDragDrop event moves the selected node on the TreeView
'control to its new location and changes the corresponding record in
'the Employees table. The procedure first checks that the TreeView
'has a selected node. If so, it continues to check if a drop target
'node is highlighted. If no node is highlighted, then the user has
'dragged the node off the tree and dropped it into a blank area, and
'the procedure adds a branch to the root of the tree. If a node is
'highlighted, the procedure modifies the Employee table's ReportTo
'field accordingly and sets the selected node's parent property
'to the node that has the drop highlight.
'==================================================================
Private Sub xTree_OLEDragDrop(Data As Object, Effect As Long, _
Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo ErrxTree_OLEDragDrop
Dim oTree As TreeView
Dim strKey As String, strText As String
Dim nodNew As Node, nodDragged As Node
Dim db As Database
Dim rs As Recordset
Set db = CurrentDb
'Open the Employees table for editing.
Set rs = db.OpenRecordset("Employees", dbOpenDynaset)
'Create a reference to the TreeView control.
Set oTree = Me!Xtree.Object
'If nothing is selected for drag, do nothing.
If oTree.SelectedItem Is Nothing Then
Else
'Reference the selected node as the one being dragged.
Set nodDragged = oTree.SelectedItem
'If the node was dragged to an empty space, update the
'Employees table and make this employee a root node.
If oTree.DropHighlight Is Nothing Then
'Save the key and the text to use when you re-add the node.
strKey = nodDragged.Key
strText = nodDragged.Text
'Delete the current node for the employee.
oTree.Nodes.Remove nodDragged.Index
'Locate the record in the Employees table and update it.
rs.FindFirst "[EmployeeID]=" & Mid(strKey, 2)
rs.Edit
rs![ReportsTo] = Null
rs.Update
'Add this employee as a root node.
Set nodNew = oTree.Nodes.Add(, , strKey, strText)
'Add all the child nodes for this employee.
AddChildren nodNew, rs
'If you are not dropping the node on itself.
ElseIf nodDragged.Index <> oTree.DropHighlight.Index Then
'Set the drop target as the selected node's parent.
Set nodDragged.Parent = oTree.DropHighlight
'Locate the record in the Employees table and update it.
rs.FindFirst "[EmployeeID]=" & Mid(nodDragged.Key, 2)
rs.Edit
rs![ReportsTo] = Mid(oTree.DropHighlight.Key, 2)
rs.Update
End If
End If
'Deselect the node
Set nodDragged = Nothing
'Unhighlight the nodes.
Set oTree.DropHighlight = Nothing
ExitxTree_OLEDragDrop:
Exit Sub
ErrxTree_OLEDragDrop:
'If you create a circular branch.
If Err.Number = 35614 Then
MsgBox "A supervisor cannot report to a subordinate.", _
vbCritical, "Move Cancelled"
Else
MsgBox "An error occurred while trying to move the node. " & _
"Please try again." & vbCrLf & Error.Description
End If
Resume ExitxTree_OLEDragDrop
End Sub |
Access 2019: TreeView LE Retour?
Répondre avec citation
Partager