VBAでTree構造を扱う

```Tree.cls
Option Explicit

Private tiHead As TreeItem

Private mblnAddDupes As Boolean
Private mvarItemToAdd As Variant

Public Sub Add(varNewItem As Variant)
    mblnAddDupes = True
    mvarItemToAdd = varNewItem
    Call AddNode(tiHead)
End Sub

Public Sub AddUnique(varNewItem As Variant)
    mblnAddDupes = False
    mvarItemToAdd = varNewItem
    Call AddNode(tiHead)
End Sub

Private Function AddNode(ti As TreeItem) As TreeItem
    
    If ti Is Nothing Then
        Set ti = New TreeItem
        ti.Value = mvarItemToAdd
    Else
        If mvarItemToAdd < ti.Value Then
            Set ti.LeftChild = AddNode(ti.LeftChild)
        ElseIf mvarItemToAdd > ti.Value Then
            Set ti.RightChild = AddNode(ti.RightChild)
        Else
            If mblnAddDupes Then
                Set ti.RightChild = AddNode(ti.RightChild)
            End If
        End If
    End If
    Set AddNode = ti
End Function

Public Sub WalkInOrder()
    Call InOrder(tiHead)
End Sub

Public Sub WalkPreOrder()
    Call PreOrder(tiHead)
End Sub

Public Sub WalkPostOrder()
    Call PostOrder(tiHead)
End Sub

Private Sub InOrder(ti As TreeItem)
    If Not ti Is Nothing Then
        Call InOrder(ti.LeftChild)
        Debug.Print ti.Value; " ";
        Call InOrder(ti.RightChild)
    End If
End Sub

Private Sub PreOrder(ti As TreeItem)
    If Not ti Is Nothing Then
        Debug.Print ti.Value; " ";
        Call PreOrder(ti.LeftChild)
        Call PreOrder(ti.RightChild)
    End If
End Sub

Private Sub PostOrder(ti As TreeItem)
    If Not ti Is Nothing Then
        Call PostOrder(ti.LeftChild)
        Call PostOrder(ti.RightChild)
        Debug.Print ti.Value; " ";
    End If
End Sub

Private Sub Class_Initialize()
    Set tiHead = Nothing
End Sub

Private Sub Class_Terminate()
    Set tiHead = Nothing
End Sub

Private Function TreeSearch(varItem As Variant, tiCurrent As TreeItem, _
 tiPrevious As TreeItem)
    If tiCurrent Is Nothing Then
        TreeSearch = False
    Else
        If tiCurrent.Value = varItem Then
            TreeSearch = True
        Else
            Set tiPrevious = tiCurrent
            If varItem < tiCurrent.Value Then
                Set tiCurrent = tiCurrent.LeftChild
            Else
                Set tiCurrent = tiCurrent.RightChild
            End If
            TreeSearch = TreeSearch(varItem, tiCurrent, tiPrevious)
        End If
    End If
End Function

Private Sub DeleteRightSubTree(tiCurrent As TreeItem, tiPrevious As TreeItem, tiRoot As TreeItem)
    Dim tiNewCurrent As TreeItem
    Dim tiNewPrevious As TreeItem
    
    Set tiNewPrevious = tiPrevious
    Set tiNewCurrent = tiCurrent.RightChild
    
    If tiPrevious Is Nothing Then
        Set tiRoot = tiCurrent.RightChild
    Else
        Set tiPrevious.RightChild = tiCurrent.RightChild
    End If
    Do Until tiNewCurrent Is Nothing
        Set tiNewPrevious = tiNewCurrent
        Set tiNewCurrent = tiNewCurrent.LeftChild
    Loop
    If tiCurrent.RightChild Is Nothing Then
        If tiPrevious Is Nothing Then
            Set tiRoot = tiCurrent.LeftChild
        Else
            Set tiPrevious.RightChild = tiCurrent.LeftChild
        End If
    Else
        If tiNewPrevious Is Nothing Then
            Set tiRoot = tiCurrent.LeftChild
        Else
            Set tiNewPrevious.LeftChild = tiCurrent.LeftChild
        End If
    End If
    Set tiCurrent = Nothing
End Sub

Private Sub DeleteLeftSubTree(tiCurrent As TreeItem, tiPrevious As TreeItem, tiRoot As TreeItem)
    Dim tiNewCurrent As TreeItem
    Dim tiNewPrevious As TreeItem
    
    Set tiNewPrevious = tiPrevious
    Set tiNewCurrent = tiCurrent.LeftChild
    
    If tiPrevious Is Nothing Then
        Set tiRoot = tiCurrent.LeftChild
    Else
        Set tiPrevious.LeftChild = tiCurrent.LeftChild
    End If
    Do Until tiNewCurrent Is Nothing
        Set tiNewPrevious = tiNewCurrent
        Set tiNewCurrent = tiNewCurrent.RightChild
    Loop
    If tiCurrent.LeftChild Is Nothing Then
        If tiPrevious Is Nothing Then
            Set tiRoot = tiCurrent.RightChild
        Else
            Set tiPrevious.LeftChild = tiCurrent.RightChild
        End If
    Else
        If tiNewPrevious Is Nothing Then
            Set tiRoot = tiCurrent.RightChild
        Else
            Set tiNewPrevious.RightChild = tiCurrent.RightChild
        End If
    End If
    Set tiCurrent = Nothing
End Sub

Public Function TreeDelete(varValue As Variant) As Boolean
    Dim tiCurrent As TreeItem
    Dim tiPrevious As TreeItem
    Dim blnFound As Boolean
    
    Set tiCurrent = tiHead
    Set tiPrevious = Nothing
    
    blnFound = TreeSearch(varValue, tiCurrent, tiPrevious)
    If blnFound Then
        If Not tiPrevious Is Nothing Then
            If varValue < tiPrevious.Value Then
                Call DeleteLeftSubTree(tiCurrent, tiPrevious, tiHead)
            Else
                Call DeleteRightSubTree(tiCurrent, tiPrevious, tiHead)
            End If
        Else
            Call DeleteRightSubTree(tiCurrent, tiPrevious, tiHead)
        End If
    End If
    TreeDelete = blnFound
End Function
```

```TreeItems.cls
Option Explicit

Public Value As Variant
Public LeftChild As TreeItem
Public RightChild As TreeItem

Private Sub Class_Initialize()
    Set LeftChild = Nothing
    Set RightChild = Nothing
End Sub

Private Sub Class_Terminate()
    Set LeftChild = Nothing
    Set RightChild = Nothing
End Sub
```
```TreeTest.bas
Attribute VB_Name = "TreeTest"
Option Explicit

Sub TestTrees()
    Dim tHead As Tree
    Set tHead = New Tree
    With tHead
        .Add "f"
        .Add "b"
        .Add "a"
        .Add "d"
        .Add "c"
        .Add "e"
        .Add "i"
        .Add "h"
        .Add "g"
        .Add "k"
        .Add "j"
        Debug.Print "InOrder: "
        Call .WalkInOrder
        Debug.Print
        
        Debug.Print "PreOrder: "
        Call .WalkPreOrder
        Debug.Print
        
        Debug.Print "PostOrder: "
        Call .WalkPostOrder
        Debug.Print
    End With
    
    Set tHead = New Tree
    With tHead
        .AddUnique "Hello"
        .AddUnique "Hello"
        .AddUnique "Hello"
        .AddUnique "Hello"
        .AddUnique "There"
        .AddUnique "My"
        .AddUnique "Name"
        .AddUnique "Is"
        .AddUnique "Ken"
        Debug.Print "====="
        Call .WalkInOrder
        Debug.Print
        Debug.Print "====="
        .TreeDelete "Hello"
        Call .WalkInOrder
        Debug.Print
        Debug.Print "====="
        .TreeDelete "Is"
        Call .WalkInOrder
        Debug.Print
    End With
    
End Sub
```