[VBA, FOSS] 1MapComparer, half product.

'#Language "WWB-COM"

Option Explicit

Function InputBoxCriterion(Prompt As String, Title As String) As Boolean
Dim userInput As String

Do
userInput = InputBox(Prompt & vbCrLf & "Enter 1 for Yes, 2 for No:", Title)

If userInput = "" Then
InputBoxCriterion = False
Exit Function
ElseIf userInput = "1" Then
InputBoxCriterion = True
Exit Function
ElseIf userInput = "2" Then
InputBoxCriterion = False
Exit Function
End If
Loop
End Function

Sub Main
Dim SelectedTopic1 As Topic
Dim SelectedTopic2 As Topic
Dim CollectedTopics1 As Variant
Dim CollectedTopics2 As Variant
Dim i As Long
Dim j As Long
Dim IsMatch As Boolean

' Comparison criteria options
Dim CompareText As Boolean
Dim CompareNotes As Boolean
Dim CompareParentTopic As Boolean

' Ensure that two topics are selected
If ActiveDocument.Selection.Count = 2 Then
' Get the selected topics
Set SelectedTopic1 = ActiveDocument.Selection.Item(1)
Set SelectedTopic2 = ActiveDocument.Selection.Item(2)

' Initialize CollectedTopics arrays
CollectedTopics1 = Array()
CollectedTopics2 = Array()

' Collect all subtopics recursively
CollectTopicsRecursively SelectedTopic1, CollectedTopics1
CollectTopicsRecursively SelectedTopic2, CollectedTopics2

' Ask the user to choose the comparison criteria
CompareText = InputBoxCriterion("Compare Text?" & vbCrLf, "Comparison Criteria")
CompareNotes = InputBoxCriterion("Compare Notes?" & vbCrLf, "Comparison Criteria")
CompareParentTopic = InputBoxCriterion("Compare ParentTopic?" & vbCrLf, "Comparison Criteria")

' Compare topics in the CollectedTopics1 and CollectedTopics2 arrays
For i = LBound(CollectedTopics1) To UBound(CollectedTopics1)
IsMatch = False
For j = LBound(CollectedTopics2) To UBound(CollectedTopics2)
If CompareTopics(CollectedTopics1(i), CollectedTopics2(j), CompareText, CompareNotes, CompareParentTopic) Then
Debug.Print "Match found between CollectedTopics1(" & i & ") and CollectedTopics2(" & j & ")"
CollectedTopics1(i).TextLabels.AddTextLabel "match"
CollectedTopics2(j).TextLabels.AddTextLabel "match"
If CompareText Then CollectedTopics1(i).TextLabels.AddTextLabel "T": CollectedTopics2(j).TextLabels.AddTextLabel "T"
If CompareNotes Then CollectedTopics1(i).TextLabels.AddTextLabel "N": CollectedTopics2(j).TextLabels.AddTextLabel "N"
If CompareParentTopic Then CollectedTopics1(i).TextLabels.AddTextLabel "P": CollectedTopics2(j).TextLabels.AddTextLabel "P"
IsMatch = True
End If
Next j
If Not IsMatch Then
CollectedTopics1(i).TextLabels.AddTextLabel "unmatch"
End If
Next i

Else
MsgBox "Please select exactly two topics.", vbExclamation, "Invalid Selection"
End If
End Sub

Sub CollectTopicsRecursively(parentTopic As Topic, ByRef CollectedTopics As Variant)
Dim subTopic As Topic
Dim newLength As Long

For Each subTopic In parentTopic.SubTopics
' Resize the CollectedTopics array to accommodate the new subtopic
If IsEmpty(CollectedTopics) Then
newLength = 0
ReDim CollectedTopics(newLength)
Else
newLength = UBound(CollectedTopics) + 1
ReDim Preserve CollectedTopics(newLength)
End If

' Add the subtopic to the CollectedTopics array
Set CollectedTopics(newLength) = subTopic

' Recursively collect subtopics of the current subtopic
CollectTopicsRecursively subTopic, CollectedTopics
Next subTopic
End Sub

Function CompareTopics(Topic1 As Topic, Topic2 As Topic, CompareText As Boolean, CompareNotes As Boolean, CompareParentTopic As Boolean) As Boolean
' Compare topic text, notes, and parent topic based on user-selected criteria
CompareTopics = True

If CompareText And Topic1.Text <> Topic2.Text Then
CompareTopics = False
ElseIf CompareNotes And Topic1.Notes.Text <> Topic2.Notes.Text Then
CompareTopics = False
ElseIf CompareParentTopic And Topic1.ParentTopic.Text <> Topic2.ParentTopic.Text Then
CompareTopics = False
End If
End Function