Hi Richard,
It is certainly possible but does require a lot of coding. You will need to
write SQL statements for each level of the tree (if the source of the data
for the tree will be tables in your database). I have included some sample
code that I use to populate a tree with in a datbase I have. You may also
like to use a listview control to show related data (which the following is
set up to do). This code supports use of three levels (not including the
root level) and both procedures are required. You could replace the SQL
with something relative to your database and see how you go. You'll need a
TreeView and ListView control, and if you want icons (the easy way) an
ImageList control to store them in.
Sub PopulateTree()
Dim intIndex As Integer
Dim intIndex2 As Integer
Dim lngCntKey As Long
Dim intDocTypeKey As Integer
Dim lngDocKey As Long
Dim iml As Object
Me.ocxTree.Nodes.Clear
'Client groups
strClientGroupSQL = "SELECT * FROM tblClientGroups ORDER BY ClientCode"
'Clients
strClientSQL = "SELECT * FROM tblClients ORDER By LName, FName"
'Client document types
strClientDocumentTypesSQL = "SELECT DISTINCT CD.ClientGroupID, "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "CD.ClientID, "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "DT.DocumentTypeID,
"
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "DT.DocumentType "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "FROM "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "tblDocumentTypes AS
DT INNER JOIN "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "(tblDocuments AS D
INNER JOIN "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "tblClientDocuments
AS CD ON D.DocumentID = CD.DocumentID) ON "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "DT.DocumentTypeID =
D.DocumentTypeID "
strClientDocumentTypesSQL = strClientDocumentTypesSQL & "ORDER BY
DT.DocumentType"
lngCntKey = 0
intDocTypeKey = 0
Set Cnn = CurrentProject.Connection
'Set rsClientGroups = New ADODB.Recordset
' Open the recordsets you will be using to populate the tree view
control
rsClientGroups.Open strClientGroupSQL, Cnn, adOpenKeyset,
adLockOptimistic
rsClients.Open strClientSQL, Cnn, adOpenKeyset, adLockOptimistic
rsClientDocumentTypes.Open strClientDocumentTypesSQL, Cnn, adOpenKeyset,
adLockOptimistic
'rsClientDocuments.Open strClientDocumentsSQL, Cnn, adOpenKeyset,
adLockOptimistic
'ocxTree.Sorted = True 'You can set this at design time by using the
controls properties
Set mNode = ocxTree.Nodes.Add(, , , "Group") ' Create the first (root)
node.
mNode.Text = "Client Groups" 'Name the root node
mNode.Tag = "Root"
mNode.Image = "Group"
rsClientGroups.MoveFirst
If rsClientGroups.BOF Then
MsgBox "There are no client groups in your database!",
vbExclamation, gstrAppName
DoCmd.Close acForm, "frmClientGroupTree", acSaveNo
GoTo Exit_PopulateTree
Else
Do 'Loop thru client groups
Set mNode = ocxTree.Nodes.Add(1, tvwChild)
If IsNull(rsClientGroups.Fields("ClientGroupID")) Then
mNode.Text = "Client Group ID not entered"
Else: mNode.Text = rsClientGroups.Fields("ClientCode")
End If
mNode.Tag = "Groups"
mNode.Key = rsClientGroups.Fields("ClientGroupID") & " GrpID"
mNode.Image = "Group"
intIndex = mNode.Index
'Loop through clients for current group
Do
If rsClients.EOF Then Exit Do
If rsClientGroups.Fields("ClientGroupID") =
rsClients.Fields("ClientGroupID") Then
Set mNode = ocxTree.Nodes.Add(intIndex, tvwChild)
mNode.Text = "Client ID :" &
rsClients.Fields("ClientID") & _
" - " & rsClients.Fields("Lname") & ", " &
rsClients.Fields("Fname") ' Text property.
mNode.Tag = "Clients" 'Set tag property to use as
reference for tvw control
mNode.Key = (rsClients.Fields("ClientID") & _
rsClients.Fields("ClientGroupID") & "ClientID" &
lngCntKey) 'Set key value (ensure & " ID" is added because of Val reference
in tvw control
mNode.Image = "Client"
intIndex2 = mNode.Index
'Loop through document types for current client
Do
If rsClientDocumentTypes.EOF Then Exit Do
If rsClients.Fields("ClientID") &
rsClients.Fields("ClientGroupID") & intDocTypeKey = _
rsClientDocumentTypes.Fields("ClientID") &
rsClientDocumentTypes.Fields("ClientGroupID") & intDocTypeKey Then
Set mNode = ocxTree.Nodes.Add(intIndex2,
tvwChild)
mNode.Text =
rsClientDocumentTypes.Fields("DocumentType")
mNode.Tag = "Document Types"
mNode.Key =
rsClientDocumentTypes.Fields("DocumentTypeID") & _
rsClientDocumentTypes.Fields("ClientGroupID")
& _
rsClientDocumentTypes.Fields("ClientID")
& " ID" & intDocTypeKey
mNode.Image = "Document"
End If
If Not rsClientDocumentTypes.EOF Then
rsClientDocumentTypes.MoveNext
intDocTypeKey = intDocTypeKey + 1
Loop Until rsClientDocumentTypes.EOF
End If
rsClientDocumentTypes.MoveFirst
rsClients.MoveNext
lngCntKey = lngCntKey + 1
Loop Until rsClients.EOF
rsClients.MoveFirst
rsClientGroups.MoveNext
Loop Until rsClientGroups.EOF
End If
'Close and clear recordsets and connection
rsClientGroups.Close
rsClients.Close
rsClientDocumentTypes.Close
Set rsClientGroups = Nothing
Set rsClients = Nothing
Set rsClientDocumentTypes = Nothing
Set Cnn = Nothing
Exit_PopulateTree:
Exit Sub
Err_PopulateTree:
Msgbox Err.Number & "; " & Err.Description
Exit Sub
End Sub
'***********
'Code for populating Listview follows...
'***********************************************************************************
'Sub populates a listview control based on the source specified in the
variable SourceName
'A field count of the data source is done and the columns of the listview
are evenly
'distrubuted across the breadth of the control. The connection object is
not declared here as it is
'done at the module level, but you will have to declare that also if you
haven't already
'Nulls are handled in this procedure.
'***********************************************************************************
Sub PopListView(SourceName As String, ListViewControlName As Object)
On Error GoTo Err_cmdPoplistView_Click
Dim clmx As ColumnHeader
Dim lvw As Object
Dim lvwItems As ListItems
Dim lvwItem As ListItem
Dim slvwItem As ListSubItem
Dim i As Integer, intPopSubItems As Integer, intRstCtr As Integer, intCtr As
Integer, intFldCount As Integer
'Dim Cnn As New ADODB.Connection 'This is declared at module level as the
treeview also uses it
Dim rst As New ADODB.Recordset, varRstValue As Variant, varTextValue As
Variant
Set Cnn = CurrentProject.Connection
intFldCount = 0
intCtr = 0
With rst
.Open SourceName, Cnn, adOpenKeyset, adLockOptimistic
If rst.RecordCount > 0 Then
.MoveLast
.MoveFirst
intRstCtr = .RecordCount
End If
End With
intFldCount = ListViewControlName.ColumnHeaders.Count 'rst.Fields.Count
ListViewControlName.View = lvwReport 'use reportview no icons
'Remove existing headers
For intCtr = 1 To intFldCount
ListViewControlName.ColumnHeaders.Remove (intFldCount)
intFldCount = intFldCount - 1
Next intCtr
'Now add back the columns using the fields in the recordset
'Use the loop to set the column names and size evenly by getting the
total
'size of the control, then dividing by the number of fields to be added
intCtr = 0 'Reset this counter
intFldCount = rst.Fields.Count
For intCtr = 0 To intFldCount - 1
Set clmx = ListViewControlName.ColumnHeaders.Add(, ,
rst.Fields(intCtr).Name, ListViewControlName.Width / intFldCount)
Next intCtr
'Populate list items with data from recordset
'"Text" is always the first column in a list item
'Everything following is a subitem (they're really just the rest of the
fields in the record)!
'You must have columns to have subitems
'The subitem count is always one less than the column count...
'Why? Because the first column is the "text" column so we don't count
that!
Set lvw = ListViewControlName 'Initialise the object
If lvw.ListItems.Count > 0 Then Me.lvwDetails.ListItems.Clear 'If items
already exist, delete them!
If rst.RecordCount > 0 Then 'If there are records process them,
otherwise close and clear
For i = 0 To intRstCtr 'Reset counter
Set lvwItem = lvw.ListItems.Add() 'Initialise the listview item
and prepare to add
'lvwItem.SmallIcon = 1 'Comment this out if you haven't
initialised an image list
varTextValue = Nz(rst.Fields(0), "Null")
For intPopSubItems = 1 To intFldCount - 1 'Now loop through the
subitems (other fields)
lvwItem.Text = varTextValue
varRstValue = Nz(rst.Fields(intPopSubItems), "Null")
lvwItem.SubItems(intPopSubItems) = varRstValue 'Assign the
rst value to the subitem (allow for nulls with Nz() )
Next intPopSubItems 'Keep going until you've done them all!
rst.MoveNext 'Done them all? OK, move to the next record in the
rst!
If rst.EOF Then Exit For 'Test for rst.eof. If true, get out of
there!
Next i 'Increment the outer loop to move down a row on the list view
and do it all again
End If
'Clean up those open objects!
rst.Close
Cnn.Close
Set rst = Nothing
Set Cnn = Nothing
Exit_cmdPoplistView_Click:
Exit Sub
Err_cmdPoplistView_Click:
Msgbox Err.Number & "; " & Err.Description 'This is a basic msgbox
only - tart it up however you like
Resume Exit_cmdPoplistView_Click
End Sub
Jamie
Server side anti spam rules are enforced and ALL unsolicited email is
deleted.
