Дан указатель Р1 на корень непустого генеалогического дерева

Option Explicit
 
Private Type Node
    Name        As Long
    Parent      As Long
    ChildCount  As Long
    Child()     As Long
End Type
 
Dim Names()     As Variant
Dim Tree()      As Node
Dim maxw        As Long
Dim maxh        As Long
 
Private Sub Form_Load()
    Dim i1 As Long, i2 As Long, r As Long
    
    Randomize
    
    AutoRedraw = True: FillStyle = vbSolid: FillColor = vbWhite: ScaleMode = vbPixels
    Names = Array("Александр", "Анатолий", "Виктор", "Алексей", "Дмитрий", "Василий", "Петр", "Иван", _
                  "Николай", "Федор", "Михаил", "Григорий", "Леонид", "Никита", "Илья", "Степан", _
                  "Станислав", "Роман", "Сергей", "Антон")
    Create -1, 4
    Draw 0, 5, 5
    Me.Width = (Width - ScaleWidth * Screen.TwipsPerPixelX) + (maxw + 10) * Screen.TwipsPerPixelX
    Me.Height = (Height - ScaleHeight * Screen.TwipsPerPixelY) + (maxh + 10) * Screen.TwipsPerPixelY
    Show
    
    Do: i1 = Val(InputBox("Введите номер дальнего родственника №1", "0")): Loop While i1 > UBound(Tree)
    Do: i2 = Val(InputBox("Введите номер дальнего родственника №2", "0")): Loop While i2 > UBound(Tree)
    
    Caption = Format(i1, "00") & " " & Names(Tree(i1).Name) & " - " & Format(i2, "00") & " " & Names(Tree(i2).Name)
    r = Search(i1, i2)
    
    If r = -1 Then MsgBox "Нет общего": Exit Sub
    
    MsgBox "Общий предок: " & Format(r, "00") & " " & Names(Tree(r).Name)
End Sub
' Поиск
Private Function Search(ByVal i1 As Long, ByVal i2 As Long) As Long
    Dim ti1 As Long, ti2 As Long
    ti1 = i1
    Do Until Tree(ti1).Parent = Tree(i2).Parent
        ti1 = Tree(ti1).Parent
        If ti1 = -1 Then ti1 = i1: i2 = i2 - 1: If i2 = -1 Then Exit Do
        DoEvents
    Loop
    Search = Tree(i2).Parent
End Function
' Отрисовка
Private Sub Draw(ByVal i As Long, ByVal x As Long, y As Long)
    Dim n As Long, h As Long, w As Long, idx As Long, cap As String, ly As Long
    cap = Format(i, "00") & " " & Names(Tree(i).Name)
    ly = y: h = TextHeight(cap): w = TextWidth(cap)
    Line (x - 1, y)-Step(w + 2, h), &HF08020, B
    CurrentX = x: CurrentY = y: Print cap
    For n = 0 To Tree(i).ChildCount - 1
        Line (x + w + 2, ly + h \ 2)-(x + 100, y + h \ 2), &H808080
        idx = Tree(i).Child(n): Draw idx, x + 100, y
        If n < Tree(i).ChildCount - 1 Then y = y + h + 3
    Next
    If x + w > maxw Then maxw = x + w
    If y + h > maxh Then maxh = y + h
End Sub
' Создание дерева
Private Sub Create(ByVal Parent As Long, ByVal Level As Long)
    Dim i As Long, n As Long, c As Long
    c = Int(Rnd * 3)
    If Parent = -1 Then
        ReDim Tree(0): Parent = 0: Tree(i).Name = Int(Rnd * (UBound(Names) + 1))
        Tree(i).Parent = -1
    End If
    ReDim Tree(Parent).Child(c): Tree(Parent).ChildCount = c + 1
    For n = 0 To c
        i = UBound(Tree) + 1: ReDim Preserve Tree(i)
        Tree(Parent).Child(n) = i
        Tree(i).Name = Int(Rnd * (UBound(Names) + 1)): Tree(i).Parent = Parent
        If Level Then Create i, Level - 1
    Next
End Sub