S
Shandy
Hello people,
I have a treeviw that is showing test scripts related to a
project,
For the treeview I wish to show the status of the test
i.e. Pass or Fail. At present I have code that allows me
to show each script associate dwith each project, no
problem. Where it falls down is when I try to show a test
status as a secondary root level. Can soemone look at this
code and show me where it is going wrong?????????(Dan if u
r out there I need your help man)
'==========================================================
========
'This procedure populates the TreeView control when the
form opens.
'==========================================================
========
Private Sub Form_Load()
On Error GoTo ErrForm_Load
Dim db As Database
Dim rstProj As Recordset, rstScript 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 project & test scripts tables.
Set rstProj = db.OpenRecordset("SELECT * FROM
tblProjDetail")
Set rstScript = db.OpenRecordset("SELECT * FROM
tblTestScripts")
'Create a reference to the TreeView Control.
Set objTree = Me!xtree.Object
'Build the TreeView list of supervisors and their
employees.
Do Until rstProj.EOF
'Extract the project name.
strText = rstProj![Project_Name]
'Add a root level node to the tree for the project.
Set nodCurrent = objTree.Nodes.Add(, , "a" &
rstProj!Project_ID, _
strText)
'Use a placeholder to save this place in the
recordset.
bk = rstProj.Bookmark
AddChildren nodCurrent, rstScript
rstProj.Bookmark = bk
rstProj.MoveNext
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, bk2 As String
Dim numKey As String
'Create a reference to the TreeView control.
Set objTree = Me!xtree.Object
numKey = a
'Build a node to show PASS and then apply all child
records that equal PASS & that project id.
Set nodCurrent = objTree.Nodes.Add(nodBoss, tvwChild,
numKey, "PASS")
rst.FindFirst "[Project_ID] =" & Mid(nodBoss.Key, 2)
& "AND [Script_Pass] = True"
Do Until rst.NoMatch
'Extract a defining field of the test script in
this case it is the condition of the test
strText = rst![Script_ID] & ": " & (Space(3)) &
rst![Condition]
Set nodCurrent = objTree.Nodes.Add(nodBoss,
tvwChild, "b" & _
rst!Script_ID, strText)
'Save your place in the recordset.
bk2 = rst.Bookmark
'Add any employees for whom the current node is a
supervisor.
AddChildren nodCurrent, rst
rst.Bookmark = bk2
'Find the next record that falls under that
project ID
rst.FindNext "[Project_ID]=" & Mid(nodBoss.Key, 2)
& "AND [Script_Pass] = True"
Loop
'Build a node to show FAIL and then apply all child
records that equal FAIL & that project id.
Set nodCurrent = objTree.Nodes.Add(nodBoss, tvwChild,
numKey, "FAIL")
rst.FindFirst "[Project_ID] =" & Mid(nodBoss.Key, 2)
& "AND [Script_fail] = True"
Do Until rst.NoMatch
'Extract a defining field of the test script in
this case it is the condition of the test
strText = rst![Script_ID] & ": " & (Space(3)) &
rst![Condition]
Set nodCurrent = objTree.Nodes.Add(nodBoss,
tvwChild, "b" & _
rst!Script_ID, strText)
'Save your place in the recordset.
bk2 = rst.Bookmark
'Add any employees for whom the current node is a
supervisor.
AddChildren nodCurrent, rst
rst.Bookmark = bk2
'Find the next record that falls under that
project ID
rst.FindNext "[Project_ID]=" & Mid(nodBoss.Key, 2)
& "AND [Script_Fail] = True"
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
Thansk for your help,
Andy
I have a treeviw that is showing test scripts related to a
project,
For the treeview I wish to show the status of the test
i.e. Pass or Fail. At present I have code that allows me
to show each script associate dwith each project, no
problem. Where it falls down is when I try to show a test
status as a secondary root level. Can soemone look at this
code and show me where it is going wrong?????????(Dan if u
r out there I need your help man)
'==========================================================
========
'This procedure populates the TreeView control when the
form opens.
'==========================================================
========
Private Sub Form_Load()
On Error GoTo ErrForm_Load
Dim db As Database
Dim rstProj As Recordset, rstScript 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 project & test scripts tables.
Set rstProj = db.OpenRecordset("SELECT * FROM
tblProjDetail")
Set rstScript = db.OpenRecordset("SELECT * FROM
tblTestScripts")
'Create a reference to the TreeView Control.
Set objTree = Me!xtree.Object
'Build the TreeView list of supervisors and their
employees.
Do Until rstProj.EOF
'Extract the project name.
strText = rstProj![Project_Name]
'Add a root level node to the tree for the project.
Set nodCurrent = objTree.Nodes.Add(, , "a" &
rstProj!Project_ID, _
strText)
'Use a placeholder to save this place in the
recordset.
bk = rstProj.Bookmark
AddChildren nodCurrent, rstScript
rstProj.Bookmark = bk
rstProj.MoveNext
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, bk2 As String
Dim numKey As String
'Create a reference to the TreeView control.
Set objTree = Me!xtree.Object
numKey = a
'Build a node to show PASS and then apply all child
records that equal PASS & that project id.
Set nodCurrent = objTree.Nodes.Add(nodBoss, tvwChild,
numKey, "PASS")
rst.FindFirst "[Project_ID] =" & Mid(nodBoss.Key, 2)
& "AND [Script_Pass] = True"
Do Until rst.NoMatch
'Extract a defining field of the test script in
this case it is the condition of the test
strText = rst![Script_ID] & ": " & (Space(3)) &
rst![Condition]
Set nodCurrent = objTree.Nodes.Add(nodBoss,
tvwChild, "b" & _
rst!Script_ID, strText)
'Save your place in the recordset.
bk2 = rst.Bookmark
'Add any employees for whom the current node is a
supervisor.
AddChildren nodCurrent, rst
rst.Bookmark = bk2
'Find the next record that falls under that
project ID
rst.FindNext "[Project_ID]=" & Mid(nodBoss.Key, 2)
& "AND [Script_Pass] = True"
Loop
'Build a node to show FAIL and then apply all child
records that equal FAIL & that project id.
Set nodCurrent = objTree.Nodes.Add(nodBoss, tvwChild,
numKey, "FAIL")
rst.FindFirst "[Project_ID] =" & Mid(nodBoss.Key, 2)
& "AND [Script_fail] = True"
Do Until rst.NoMatch
'Extract a defining field of the test script in
this case it is the condition of the test
strText = rst![Script_ID] & ": " & (Space(3)) &
rst![Condition]
Set nodCurrent = objTree.Nodes.Add(nodBoss,
tvwChild, "b" & _
rst!Script_ID, strText)
'Save your place in the recordset.
bk2 = rst.Bookmark
'Add any employees for whom the current node is a
supervisor.
AddChildren nodCurrent, rst
rst.Bookmark = bk2
'Find the next record that falls under that
project ID
rst.FindNext "[Project_ID]=" & Mid(nodBoss.Key, 2)
& "AND [Script_Fail] = True"
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
Thansk for your help,
Andy