Not much to it, just a Demo for an UDT-based cNode-Class,
which can be extended (by adding Fields to the Class-internal UDT).
This Node-Class is "self-contained" (no extra-modules are needed).
Performance is quite good... adding 1,001,000 Nodes total as 1000ChildNodes on 1000ChildNodes takes:
- about 0.33sec in the IDE
- about 0.22sec native compiled (all Options)
cNode will hand out "dynamically created wrapper instances of itself -
(using internal Indexes which point into the Root-UDT-Array)", on all cNode-returning Properties, which are:
- Root() As cNode
- Parent() As cNode
- NodeById(ByVal ID As Long) As cNode
- Child(ByVal IdxZeroBased As Long) As cNode
- FirstChild() As cNode
- NextSibling() As cNode
- PrevSibling() As cNode
- LastChild() As cNode
cNode
Into a Test-Form:
Have fun,
Olaf
which can be extended (by adding Fields to the Class-internal UDT).
This Node-Class is "self-contained" (no extra-modules are needed).
Performance is quite good... adding 1,001,000 Nodes total as 1000ChildNodes on 1000ChildNodes takes:
- about 0.33sec in the IDE
- about 0.22sec native compiled (all Options)
cNode will hand out "dynamically created wrapper instances of itself -
(using internal Indexes which point into the Root-UDT-Array)", on all cNode-returning Properties, which are:
- Root() As cNode
- Parent() As cNode
- NodeById(ByVal ID As Long) As cNode
- Child(ByVal IdxZeroBased As Long) As cNode
- FirstChild() As cNode
- NextSibling() As cNode
- PrevSibling() As cNode
- LastChild() As cNode
cNode
Code:
Option Explicit
Private Declare Sub AssignArrTo Lib "kernel32" Alias "RtlMoveMemory" (pDst() As Any, pSrc() As Any, Optional ByVal CB& = 4)
Private Type tNode
PIdx As Long
ChCount As Long
ChIdxs() As Long
'define UserData-NodeProps from here onwards...
Text As String
'... a.s.o. (see the Prop-Mapping-Section at the end of this Class)
End Type
'we need only 3 Private Vars to present a Node-instance
Private mIdx As Long, mNodes() As tNode, mInternalInstance As Boolean
Private Sub Class_Initialize()
ReDim mNodes(0)
End Sub
Private Sub Class_Terminate() 'cleanup the fake arr-reference...
Dim aNull(): If mInternalInstance Then AssignArrTo mNodes, aNull '...but only when created internally here
End Sub
Public Sub AddNode(Text As String) 'for best add-performance, include all the (UDT-)Prop-Values as Params here
Dim UB As Long, CC As Long
UB = UBound(mNodes)
CC = -mNodes(0).PIdx + 1: mNodes(0).PIdx = -CC '<- mNodes(0).PIdx holds the negative, total ChildNode-Count
If CC >= UB Then ReDim Preserve mNodes(32 + CC * 1.6)
With mNodes(CC) 'set the direct UDT-entries of our new ChildNode
.PIdx = mIdx '... starting with the ParentIndex (which is the Index of *this* (Parent)Node-instance)
.Text = Text
'... a.s.o. for more UDT-Values (see the UDT-def at the top of this Class)
End With
With mNodes(mIdx) 'also put the right Index-entry into the Child-Array of the UDT for this (Parent)Node-Instance
If .ChCount = 0 Then ReDim .ChIdxs(4)
If .ChCount >= UBound(.ChIdxs) Then ReDim Preserve .ChIdxs(.ChCount * 1.6)
.ChIdxs(.ChCount) = CC 'set the Index of the new Child (CC is equivalent with that)
.ChCount = .ChCount + 1
End With
End Sub
Friend Sub Init(ByVal Idx As Long, Nodes() As tNode) 'do not call this method from the outside
mIdx = Idx: mInternalInstance = True 'set the Idx + flag this instance as "internally created"
Erase mNodes: AssignArrTo mNodes, Nodes 'make a "fake" Array-copy
End Sub
Public Property Get ID() As Long 'to provide a unique Identifier within the Tree for this Node
ID = mIdx 'on the outside, this is only useful to compare Nodes for identity
End Property
Public Property Get TotalNodeCount() As Long
TotalNodeCount = -mNodes(0).PIdx
End Property
Public Property Get Level() As Long 'determines the "Hierarchy-Depth" of the current Node
Dim i As Long: i = mIdx
Do While i: i = mNodes(i).PIdx: Level = Level + 1: Loop
End Property
Public Property Get Root() As cNode
Set Root = New cNode: Root.Init 0, mNodes
End Property
Public Property Get Parent() As cNode
If mIdx Then Set Parent = New cNode: Parent.Init mNodes(mIdx).PIdx, mNodes
End Property
Public Property Get NodeById(ByVal ID As Long) As cNode
Set NodeById = New cNode: NodeById.Init ID, mNodes
End Property
Public Property Get Child(ByVal IdxZeroBased As Long) As cNode
Set Child = New cNode: Child.Init mNodes(mIdx).ChIdxs(IdxZeroBased), mNodes
End Property
Public Property Get ChildCount() As Long
ChildCount = mNodes(mIdx).ChCount
End Property
Public Property Get FirstChild() As cNode
If mNodes(mIdx).ChCount = 0 Then Exit Property 'no first Child available here (return Nothing)
Set FirstChild = New cNode: FirstChild.Init mNodes(mIdx).ChIdxs(0), mNodes
End Property
Public Property Get NextSibling() As cNode
If mIdx = 0 Then Exit Property 'the Root-Node has no siblings
With mNodes(mNodes(mIdx).PIdx)
If .ChCount <= 1 Then Exit Property 'with a ChildCount <=1 there's no next Sibling
If .ChIdxs(.ChCount - 1) = mIdx Then Exit Property 'the last Child has no next Sibling
Dim i As Long
i = mIdx - .ChIdxs(0) 'simple optimization-attempt (avoiding the loop, when the second-next line checks out true)
If i < 0 Then i = 0 Else If i > .ChCount - 2 Then i = .ChCount - 2
If .ChIdxs(i) = mIdx Then Set NextSibling = New cNode: NextSibling.Init .ChIdxs(i + 1), mNodes: Exit Property
For i = 0 To .ChCount - 2
If .ChIdxs(i) = mIdx Then Set NextSibling = New cNode: NextSibling.Init .ChIdxs(i + 1), mNodes: Exit For
Next
End With
End Property
Public Property Get PrevSibling() As cNode
If mIdx = 0 Then Exit Property 'the Root-Node has no siblings
With mNodes(mNodes(mIdx).PIdx)
If .ChCount <= 1 Then Exit Property 'with a ChildCount <=1 there's no previous Sibling
If .ChIdxs(0) = mIdx Then Exit Property 'the first Child has no previous Sibling
Dim i As Long
i = mIdx - .ChIdxs(0) 'simple optimization-attempt (avoiding the loop, when the second-next line checks out true)
If i < 1 Then i = 1 Else If i > .ChCount - 1 Then i = .ChCount - 1
If .ChIdxs(i) = mIdx Then Set PrevSibling = New cNode: PrevSibling.Init .ChIdxs(i - 1), mNodes: Exit Property
For i = 1 To .ChCount - 1
If .ChIdxs(i) = mIdx Then Set PrevSibling = New cNode: PrevSibling.Init .ChIdxs(i - 1), mNodes: Exit For
Next
End With
End Property
Public Property Get LastChild() As cNode
If mNodes(mIdx).ChCount = 0 Then Exit Property 'no last Child available here (return Nothing)
Set LastChild = New cNode: LastChild.Init mNodes(mIdx).ChIdxs(mNodes(mIdx).ChCount - 1), mNodes
End Property
'Ok, finally the mapping of (non-navigation-related) UDT-Props to and from the outside
Public Property Get Text() As String
Text = mNodes(mIdx).Text
End Property
Public Property Let Text(RHS As String)
mNodes(mIdx).Text = RHS
End PropertyCode:
Option Explicit
Private Root As cNode
Private Sub Form_Click()
AutoRedraw = True: FontName = "Tahoma": Cls: Tag = Timer
If Root Is Nothing Then
Set Root = New cNode 'only Root-Nodes are created with the New-Operator (on the outside of cNode)
Root.Text = "RootNode"
AddChildNodesTo Root, 1000, "ChildLevel1_"
Dim i As Long
For i = 0 To Root.ChildCount - 1
AddChildNodesTo Root.Child(i), 1000, "ChildLevel2_"
Next
Print "Construction-Time:", Format(Timer - Tag, " 0.00sec")
Print "Total-NodeCount:", Root.TotalNodeCount
Print "Root-ChildCount:", Root.ChildCount
Print "ChildCount of a Level1-Child: "; Root.FirstChild.ChildCount
Print "ChildCount of a Level2-Child: "; Root.FirstChild.FirstChild.ChildCount
Print "Level-PrintOut:", Root.Level; Root.LastChild.Level; Root.LastChild.LastChild.Level
With Root.LastChild.LastChild
Print vbLf; "Infos for the Last ChildNode:"; vbLf; " " & .Text
Print " IsChildOf: "; .Parent.Text
Print " IsChildOf: "; .Parent.Parent.Text
End With
Else
Set Root = Nothing
Print "Destruction-Time:", Format(Timer - Tag, " 0.00sec")
End If
End Sub
Sub AddChildNodesTo(N As cNode, ByVal ChildCount As Long, TextPrefix As String)
Dim i As Long
For i = 0 To ChildCount - 1: N.AddNode TextPrefix & i: Next
End SubOlaf