'#Language "WWB-COM"

' Title:
' M4 sample - Transactions 2
' © 2015 Harport Consulting

' Description:
' Use a transaction to create very large maps

Option Explicit

Const B_UseTransaction = True ' Use transaction event, or use in-line code

Const T_AppName = "Large Map Generator" ' X-Macro name: change only the string between the speech marks
Const T_AppVer = "2.0" ' Macro version
Const T_Caption = "%a% %v%"
Const v_MapChoice = vbOkCancel ' vbOKCancel allows user to overwrite existing map, or cancel
Const T_ReplaceTopics = "Overwrite %1% existing topics in the current map?"
Const T_Input = "Enter number of Subtopics to create at each level, separated by commas.%n%%n%Example: 10,9 will create 10 Main Topics, each with 9 Subtopics."
Const T_Default = "10,9"
Const T_Confirm = "Create %1% Subtopics?"
Const T_DebugStart = "Creating %1% Subtopics..."
Const T_DebugUpdate = "%1% Subtopics added"

Dim s_Input As String
Dim i_SubtopicCounts() As Integer ' array of subtopic counts at each level
Dim i_TotalTopics() As Integer ' array of total numbers of topics at each level
Dim i_RenderedTopics() As Integer ' array of topics rendered so far at each level
Dim i_Topics As Integer
Dim i_TopicsAdded As Integer
Dim i_Counter1 As Integer
Dim i_RefTimer As Decimal ' Timer start value
Dim WithEvents m_Trans As Transaction ' Transaction object

Sub Main
' Prompt for dimensions and build map
	Dim m_Doc As Document
	Dim i_1 As Integer
	Dim i_2 As Integer
	Dim a_Input() As String
	Dim b_OK As Boolean

	Debug.Clear

	b_OK = False
	s_Input = T_Default ' default
	While True
		s_Input = Replace(InputBox(strFormat(T_Input), strFormat(T_Caption), s_Input), " ", "") ' strip all spaces
		If Len(s_Input) = 0 Then ' cancelled
   			b_OK = False
			Exit While
		Else ' input provided
			a_Input = Split(s_Input, ",") ' split by comma
		   	ReDim i_SubtopicCounts(1 To UBound(a_Input) + 1)
		   	ReDim i_TotalTopics(1 To UBound(a_Input) + 1)
		   	ReDim i_RenderedTopics(1 To UBound(a_Input) + 1)
			For i_1 = 0 To UBound(a_Input)
				b_OK = False
				If Len(a_Input(i_1)) > 0 Then ' something defined
					If IsNumeric(a_Input(i_1)) Then ' is a number
						i_SubtopicCounts(i_1 + 1) = CInt(a_Input(i_1))
						If i_SubtopicCounts(i_1 + 1) > 0 Then ' is positive and greater than zero
							b_OK = True
						End If
					End If
				End If
				If Not b_OK Then Exit For ' leave loop if invalid input
			Next i_1

			If b_OK Then ' calculate number of topics to create
				i_Topics = 0 ' total topics
				i_2 = 1 ' central topic
				For i_1 = 1 To UBound(i_SubtopicCounts)
					i_2 = i_2 * i_SubtopicCounts(i_1) ' number of topics at this level
					i_TotalTopics(i_1) = i_2
					i_Topics = i_Topics + i_2 ' number of topics overall
				Next i_1
				Select Case MsgBox(strFormat(T_Confirm, i_Topics), vbQuestion + vbYesNoCancel, strFormat(T_Caption))
					Case vbYes
						Exit While
					Case vbCancel
						b_OK = False
					Exit While
				End Select
			End If
		End If
	Wend

	If b_OK Then
		Set m_Doc = DocumentGet
		If Not (m_Doc Is Nothing) Then ' not cancelled
			i_RefTimer = Timer
			DebugPrint("Use Transaction: " & CStr(B_UseTransaction))
			If B_UseTransaction Then
				Call TransactionRun(m_Doc) ' use this for production, as it is faster
			Else
				m_trans_Execute(m_Doc) ' use this for debug, as events can stop if the transaction object is stopped with a breakpoint
			End If
			Set m_Doc = Nothing
		End If
	End If

	DebugPrint("Finished")

End Sub

Sub TransactionRun(ByVal m_Document As Document)
' Run the transaction

	Set m_Trans = m_Document.NewTransaction(T_AppName)
	' Kick off transaction
	If Not m_Trans Is Nothing Then
		m_Trans.Start
		Wait(0.1)
		' Wait for it to finish
		While m_Trans.IsExecuting
			Wait (0.1) ' maximum error in timing results
		Wend
		Set m_Trans = Nothing
	End If

End Sub

Sub m_trans_Execute(ByVal m_Document As Document)
' Export to the transaction object then update it

	Call TopicCount(True) ' reset
	Call SubTopicsAdd(m_Document.CentralTopic, 1) ' start at level 1
	Call TopicCustomise(m_Document.CentralTopic, 0, 1) ' central topic is level 0

End Sub

Function DocumentGet() As Document
' Get the document to populate
' If there is no document then create a new one
' If there is a document then offer to ovewrite it
' Return null pointer if user cancels, else return new document pointer

	Set DocumentGet = Nothing
	If Documents(False).Count = 0 Then ' no documents, start a new one
		Set DocumentGet = Documents(False).Add
	Else ' a visible document exists
		If ActiveDocument.Range(mmRangeAllTopics).Count > 1 Then ' topics already exist
			Select Case MsgBox(strFormat(T_ReplaceTopics, ActiveDocument.Range(mmRangeAllTopics).Count), vbQuestion + v_MapChoice, strFormat(T_Caption))
				Case vbNo ' create new map
			 		Set DocumentGet = Documents(False).Add

				Case vbCancel ' do nothing

				Case Else ' vbYes or vbOK
			 		While ActiveDocument.CentralTopic.SubTopics(True).Count > 0
						ActiveDocument.CentralTopic.SubTopics(True).Item(1).Delete
			 		Wend
			 		Set DocumentGet = ActiveDocument

			End Select

		Else ' empty map exists
			Set DocumentGet = ActiveDocument
		End If
	End If

End Function

Sub SubTopicsAdd(ByVal m_b1 As Topic, ByVal i_Level As Integer)
' Add the subtopics to a topic at the current generation
' If not at the highest generation then recurse
	Dim i_1 As Integer
	Dim m_b2 As Topic

	For i_1 = 1 To i_SubtopicCounts(i_Level)
		Call TopicCount(False, i_Level)
		Set m_b2 = m_b1.AddSubTopic("")
		Call TopicCustomise(m_b2, i_Level, i_1)
		If i_Level < UBound(i_SubtopicCounts) Then
			Call SubTopicsAdd(m_b2, i_Level + 1)
		End If
	Next
	Set m_b2 = Nothing

End Sub

Sub TopicCount(ByVal b_Reset As Boolean, Optional ByVal i_Level As Integer = 0)
' Count a topic
	Dim i_1 As Integer

	If b_Reset Then ' reset counters
		i_Counter1 = 0
		i_TopicsAdded = 0
		For i_1 = 1 To UBound(i_RenderedTopics)
			i_RenderedTopics(i_1) = 0
		Next i_1
		DebugPrint(strFormat(T_DebugStart, i_Topics))
	Else ' count up
		i_RenderedTopics(i_Level) = i_RenderedTopics(i_Level) + 1 ' count at this level
		i_TopicsAdded = i_TopicsAdded + 1 ' count globally
		i_Counter1 = i_Counter1 + 1
		If i_Counter1 >= 100 Then
			i_Counter1 = 0
			DebugPrint(strFormat(T_DebugUpdate, i_TopicsAdded))
		End If
	End If

End Sub

Sub TopicCustomise(ByVal m_Topic As Topic, ByVal i_Level As Integer, ByVal i_Index As Integer)
' Apply content to a topic
' The index is 1-inclusive and is the index in the subtopics of the parent
' The level is 0-inclusive
	Const T_CentralTopic = "%1% Subtopics%n%(%2%)"
	Const T_Subtopic = "Topic %1%/%2%"

	With m_Topic
		If i_Level = 0 Then ' central topic
			.Text = strFormat(T_CentralTopic, i_Topics, s_Input)
		Else ' subtopic
			.Text = strFormat(T_Subtopic, i_RenderedTopics(i_Level), i_TotalTopics(i_Level))
		End If
	End With

End Sub

Function strFormat(ByVal s_Text As String, Optional ByVal v_1 As Variant, Optional ByVal v_2 As Variant, Optional ByVal v_3 As Variant, _
Optional ByVal v_4 As Variant, Optional ByVal v_5 As Variant, Optional ByVal v_6 As Variant) As String
' Format a string for display, substituting placeholders
' %n% > vbcrlf
' %a% > T_AppName
' %v% > T_AppVer
' %1% > s_1 etc

	If Not IsMissing(v_1) Then s_Text = Replace(s_Text, "%1%", CStr(v_1))
	If Not IsMissing(v_2) Then s_Text = Replace(s_Text, "%2%", CStr(v_2))
	If Not IsMissing(v_3) Then s_Text = Replace(s_Text, "%3%", CStr(v_3))
	If Not IsMissing(v_4) Then s_Text = Replace(s_Text, "%4%", CStr(v_4))
	If Not IsMissing(v_5) Then s_Text = Replace(s_Text, "%5%", CStr(v_5))
	If Not IsMissing(v_6) Then s_Text = Replace(s_Text, "%6%", CStr(v_6))
	strFormat = Replace(Replace(Replace(s_Text, "%a%", T_AppName), "%v%", T_AppVer),  "%n%", vbCrLf)

End Function

Sub DebugPrint(ByVal s_Message As String)
' Print a string to the debug window

	Debug.Print("[" & Format(Timer - i_RefTimer, "000.000") & "] " & s_Message)

End Sub