Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Private Sub Form_Load()
'Build the Nodes for the TreeView Control
With MyTreeView.Nodes
'Parent node
.Add , , "EQPARENT", "Equipment"
'Child nodes
.Add "EQPARENT", tvwChild, , "Equip Child 1"
.Add "EQPARENT", tvwChild, , "Equip Child 2"
End With
End Sub
Option Compare Database
Private Sub cmdCollapseNodes_Click()
'Collapse all node
For Each Node In MyTreeView.Nodes
Node.Expanded = False
Next
End Sub
Private Sub cmdExpandNodes_Click()
'Expand all nodes
For Each Node In MyTreeView.Nodes
Node.Expanded = True
Next
End Sub
Private Sub Form_Load()
' call sub to populate nodes
AddNodes
End Sub
Private Sub MyTreeView_Collapse(ByVal Node As Object)
' change node image to + if collapsing the node
' except were node is terminal i.e has no child node of it's own
If Node.Child = Null Then
Node.Image = "img3"
Else
Node.Image = "img1"
End If
End Sub
Private Sub MyTreeView_Expand(ByVal Node As Object)
' change node image to - if collapsing the node
' except were node is terminal i.e has no child node of it's own
If Node.Child = Null Then
Node.Image = "img3"
Else
Node.Image = "img2"
End If
End Sub
Private Sub MyTreeView_NodeCheck(ByVal Node As Object)
' sub to add extra nodes
Dim StrInput As String
Dim Nd As Node
Dim StrFullPath As String
Dim IntCountFields As Integer
Dim DB As DAO.Database
Dim Rst As DAO.Recordset
Dim StrField As String
Dim BoolResult As Boolean
Dim IntArrayCount As Integer
'Create a node object not entirley necessary could just use "Node" however no list comes up when you type Node.
Set Nd = Node
' if user is unchecking the node then exit sub
If Nd.Checked = False Then
Set Nd = Nothing
Exit Sub
End If
' asks if user really wants to add a new node
If MsgBox("Do you wish to add a new node?", vbQuestion + vbYesNo, "Add node") = vbYes Then
' if yes then asks if the user will want to display a input box to collect a result for the node
' i.e select a blood result and ask for a value
If MsgBox("Will this node have an asscociated result i.e. Mews Score has result values 1-10", vbQuestion + vbYesNo, "Expected Result?") = vbYes Then
BoolResult = True
Else
BoolResult = False
End If
'On Error GoTo EndAdd
' asks for the name of the node, can't use a slash \ as this is used to determine the path of the node
' i.e which record in the table it is
StrInput = Trim(InputBox("Please enter the name of the node you wish to add." & vbCrLf & "You cannot use the \ character in the Node's name", "Node Name Request"))
' calls the function to check the node name is valid
' warns user if it is invalid i.e uses a \
If CheckNewFieldValidity(StrInput) = False Then
MsgBox "You have used the invalid character \ in the field name; Process halted", vbCritical, "Data Error"
Set Nd = Nothing
Exit Sub
End If
' count the number of slashes in the node path this is used latter to add the new node
' slahes is always one less than number of nodes = field
IntCountFields = 0
StrFullPath = Nd.FullPath & "\" & StrInputs ' add the new node name to the path before counting
Do Until InStr(1, StrFullPath, "\") = 0
IntCountFields = IntCountFields + 1
StrFullPath = Mid(StrFullPath, InStr(1, StrFullPath, "\") + 1)
Loop
' if the \ count exceeds 3 then there will be to many nodes. The limit is set by the number of fields
' in Tbl_obs_l i've used 4 levels/fields
If IntCountFields > 3 Then
MsgBox "Unable to add any more levels; Process halted", vbCritical, "Maximum Number of Levels Reached"
Set Nd = Nothing
Exit Sub
End If
' make a recordset of the tbl_obs_l
Set DB = CurrentDb
Set Rst = DB.OpenRecordset("TBL_OBS_L")
' get the full path + the name of the new node
StrFullPath = Nd.FullPath & "\" & StrInput
' add each node name to the table and the new node name to create a new record
Rst.AddNew
IntArrayCount = 1
For IntCountFields = IntCountFields To 1 Step -1
StrField = Mid(StrFullPath, 1, InStr(1, StrFullPath, "\") - 1)
Rst.Fields("OBS_L" & IntArrayCount) = StrField
StrFullPath = Mid(StrFullPath, InStr(1, StrFullPath, "\") + 1)
IntArrayCount = IntArrayCount + 1
Next IntCountFields
Rst.Fields("OBS_L" & IntArrayCount) = StrFullPath
Rst![RESULT] = BoolResult
Rst.Update
' call addnodes to update the new data
AddNodes
End If
Set DB = Nothing
Set Rst = Nothing
Set Nd = Nothing
Exit Sub
EndAdd:
MsgBox "You have not entered a node name; Process Halted", vbExclamation, "New Node Cancelled"
Set Nd = Nothing
End Sub
Private Sub MyTreeView_NodeClick(ByVal Node As Object)
' add the selected node data to the table
Dim Nd As Node
Dim IntChildren As Integer
Dim StrFullPath As String
Dim IntCountFields As Integer
Dim IntArrayCount As Integer
Dim StrSQL As String
Dim DB As DAO.Database
Dim Rst(1) As DAO.Recordset
Dim StrField As String
' If the node has no child node then it can be saved to the data table
Set Nd = Node
IntChildren = Nd.Children
If IntChildren = 0 Then
StrFullPath = Nd.FullPath
Else
Set Nd = Nothing
Exit Sub
End If
' counts the number of slashes in the path name
' this allows us to split the path to get the individual nodes and therefore the data in tbl_obs_l
IntCountFields = 0
Do Until InStr(1, StrFullPath, "\") = 0
IntCountFields = IntCountFields + 1
StrFullPath = Mid(StrFullPath, InStr(1, StrFullPath, "\") + 1)
Loop
' Basically as each "branch" of the tree is a record from tbl_obs_l then we can reconstruct the data in the
' record and run a select sql that will give us the primary key for that record this means we can store the primary
' key in tbl_observations
' If there is only 1 field then create this sql string IntCountFields = 0 Then
If IntCountFields = 0 Then
StrSQL = "SELECT TBL_OBS_L.* FROM TBL_OBS_L WHERE(((TBL_OBS_L.OBS_L1)='" & StrFullPath & "'));"
Else
' if there are 2+ nodes then create this sql
StrFullPath = Nd.FullPath
IntArrayCount = 1
StrSQL = "SELECT TBL_OBS_L.* FROM TBL_OBS_L WHERE("
For IntCountFields = IntCountFields To 1 Step -1
StrField = Mid(StrFullPath, 1, InStr(1, StrFullPath, "\") - 1)
StrSQL = StrSQL & "((TBL_OBS_L.OBS_L" & IntArrayCount & ")='" & StrField & "') AND "
StrFullPath = Mid(StrFullPath, InStr(1, StrFullPath, "\") + 1)
IntArrayCount = IntArrayCount + 1
Next IntCountFields
StrSQL = StrSQL & "((TBL_OBS_L.OBS_L" & IntArrayCount & ")='" & StrFullPath & "'));"
End If
' Asks the user if they want to store the data they have selected
If MsgBox("Do you wish to save this item?", vbInformation + vbYesNo, "Save Data") = vbYes Then
Set DB = CurrentDb
Set Rst(0) = DB.OpenRecordset(StrSQL)
Set Rst(1) = DB.OpenRecordset("SELECT TBL_OBSERVATIONS.* FROM TBL_OBSERVATIONS")
Rst(1).AddNew
' VISIT_FK IS THE FOREIGN KEY THAT IS USED IN THE OBSERVATIONS TABLE TO LINK THE VISIT THE NURSE MADE TO THE
' OBSERVATIONS (OBS_ID FIELD FROM TBL_OBS).
' MY DATABASE USES A SYCHRONISATION ROUTINE CONSAQUENTLY I NEED GUID AUTONUMBERS
' NORMALLY THIS WOULD BE RETRIEVED IN SOME WAY FROM THE LAST VISIT SELECTED BY THE USER.
Rst(1)![VISIT_FK] = "{6D1F5D4B-8C57-4B82-A7CA-45EEA9CA84F7}"
Rst(1)![OBS_FK] = Rst(0)![OBS_ID]
' If the user has create a field that they expect to have a result for i.e a blood result then the record
' will have a tick in the Results field from Tbl_obs_l i.e -1
If Rst(0)![RESULT] = -1 Then
Rst(1)![RESULT] = Nz(InputBox("Please enter result for this observation", "Data Request"), "No data submitted")
Else
Rst(1)![RESULT] = "N/A"
End If
Rst(1).Update
End If
' requery the subform to display the data
Me.TBL_OBSERVATIONS_subform.Requery
Set DB = Nothing
Set Rst(1) = Nothing
Set Rst(0) = Nothing
Set Nd = Nothing
End Sub
Sub AddNodes()
' Adds the data to the tree
Dim DB As DAO.Database
Dim Rst As DAO.Recordset
Dim StrParent As String
Dim StrChild As String
' create a recordset of tbk_obs_l
Set DB = CurrentDb
Set Rst = DB.OpenRecordset("Select TBL_OBS_L.* from TBL_OBS_L;")
StrParent = ""
StrChild = ""
Rst.MoveFirst
Do Until Rst.EOF = True
'Build the Nodes for the TreeView Control
' level 1 is the parent
' loops through the recordset adding data to the tree
With MyTreeView.Nodes
On Error Resume Next
StrParent = Rst![OBS_L1]
StrChild = Rst![OBS_L1]
.Add , , StrParent, StrChild
End With
Rst.MoveNext
Loop
StrParent = ""
StrChild = ""
Rst.MoveFirst
'level 2 is the parent of level3 and the child of level 1
Do Until Rst.EOF = True
StrParent = Rst![OBS_L1]
StrChild = Rst![OBS_L2]
If StrChild <> "" And StrChild <> "N/A" Then
With MyTreeView.Nodes
.Add StrParent, tvwChild, StrChild, StrChild
End With
End If
Rst.MoveNext
Loop
StrParent = ""
StrChild = ""
Rst.MoveFirst
'level 3 is the parent of level4 and the child of level 2
Do Until Rst.EOF = True
StrParent = Rst![OBS_L2]
StrChild = Rst![OBS_L3]
If StrChild <> "" And StrChild <> "N/A" Then
With MyTreeView.Nodes
.Add StrParent, tvwChild, StrChild, StrChild
End With
End If
Rst.MoveNext
Loop
StrParent = ""
StrChild = ""
Rst.MoveFirst
'level 4 is the parent of level3 and has no children
Do Until Rst.EOF = True
StrParent = Rst![OBS_L3]
StrChild = Rst![OBS_L4]
If StrChild <> "" And StrChild <> "N/A" Then
With MyTreeView.Nodes
.Add StrParent, tvwChild, StrChild, StrChild
End With
End If
Rst.MoveNext
Loop
' adds images to the nodes
Dim Nds As Nodes
Dim Nd As Node
Set Nds = MyTreeView.Nodes
For Each Nd In Nds
If Nd.Child = Null Then ' if child node then add red square
Nd.Image = "img3"
ElseIf Nd.Expanded = True Then
Nd.Image = "img2" 'if expanded parent then show "-" image
ElseIf Nd.Expanded = False Then
Nd.Image = "img1" ' if collapsed node then show "+" image
End If
Next Nd
Set Rst = Nothing
Set DB = Nothing
End Sub
Function CheckNewFieldValidity(StrInput As String) As Boolean
' checks that there are no slashes \ in the new node name.
If InStr(1, StrInput, "\") <> 0 Then
CheckNewFieldValidity = False
Else
CheckNewFieldValidity = True
End If
End Function
Private Sub MyTreeView_Expand(ByVal Node As Object)
[green]' change node image to - if collapsing the node
' except were node is terminal i.e has no child node of it's own[/green]
If Node.Child = Null Then
Node.Image = "img3"
Else
Node.Image = "img2"
End If
End Sub
[white]'[/white]
Private Sub MyTreeView_Expand(ByVal nodCurrent As Node)
With nodCurrent
If IsNull(.Child) Then
.Image = "imgCollapsed"
Else
.Image = "imgExpanded"
End If
End With
End Sub
[white]'[/white]