VBS: Представить текст как "дерево"

Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")

strScriptPath = Trim(Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\")))

Dim sFile, sTextFile

sFile = strScriptPath & "prt.txt"
sFileNew = strScriptPath & "prtNew.txt"

sTextTemp = vbNullString

Const adVarChar = 200
Const adInteger = 3
Const adSingle = 4
Const adDate = 7
Const adFldMayBeNull = &H40
Const adFldFixed = &H10
Const adFldKeyColumn = &H8000

'----- CursorTypeEnum Values ----------

Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3

'---- CursorLocationEnum Values ----
Const adUseClient = 1
Const adUseServer = 2
Const adUseClientBatch = 3

'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4

Dim ArrLevel()
ReDim ArrLevel(0)

ArrLevel(0) = 0

If objFSO.FileExists(sFile) Then
	Set objFile = objFSO.OpenTextFile(sFile, 1, False)
'	Set objFile_New = objFSO.CreateTextFile(sFileNew, True)

	Dim objRSTextFile : Set objRSTextFile = CreateObject("ADODB.RecordSet")

	With objRSTextFile
		.Fields.Append "NumStr", adInteger,, adFldFixed
		.Fields.Append "Line", adVarChar, 1000, adFldMayBeNull
		.Fields.Append "Space", adInteger,, adFldFixed
		.Fields.Append "LvlTree", adInteger,, adFldFixed

		.CursorType = adOpenKeyset
		.CursorLocation = adUseClient
		.LockType = adLockPessimistic
		.Open
	End With

	iLine = 0

	Do Until objFile.AtEndOfStream
		sLine = vbNullString
		sLine = objFile.ReadLine

		flagNull = False
		iCount = 0
		iLen = 1

		If Trim(sLine) <> vbNullString Then
			objRSTextFile.AddNew
			objRSTextFile.Fields("NumStr") = iLine
			objRSTextFile.Fields("Line") = sLine

			Do Until (iLen > Len(sLine)) Or flagNull
				If Mid(sLine, iLen, 1) = " " Then
					iCount = iCount + 1
				Else
					flagNull = True
				End If
				iLen = iLen + 1
			Loop

			objRSTextFile.Fields("Space") = iCount

			flagExist = False
			iLvl = 0
			Do Until  (iLvl > UBound(ArrLevel)) Or (flagExist)
				If ArrLevel(iLvl) = iCount Then _
					flagExist = True
				iLvl = iLvl + 1
			Loop

			If Not flagExist Then
				ReDim Preserve ArrLevel(Ubound(ArrLevel) + 1)
				ArrLevel(Ubound(ArrLevel)) = CInt(iCount)
			End If

			iLine = iLine + 1
		End If
	Loop

	Call QuickSortArray(ArrLevel, GetRef("Cmp_Any"))

	For i = LBound(ArrLevel) to UBound(ArrLevel)
		With objRSTextFile
			.Filter = "Space = '" & ArrLevel(i) & "'"
			If .RecordCount > 0 Then
				.MoveFirst
				Do Until .EOF
					.Fields("LvlTree") = i + 1
					.MoveNext
				Loop
			End If
		End With
	Next

	iNumNode_First = 0
	iNumLevel_First = 0
	iNumNode_Next = 0

	With objRSTextFile
		.Filter = "Line LIKE 'CLS *'"
		If .RecordCount > 0 Then
			.MoveFirst
			iNumNode_First = .Fields("NumStr")
			iNumLevel_First = .Fields("Space")
		End If
	End With

	sTempStr =vbNullString

	If iNumNode_First > 0 Then

		With objRSTextFile
			.Sort = "NumStr ASC"
			.Filter = "NumStr > '" & iNumNode_First & "' And Space='" & iNumLevel_First & "'"
			If .RecordCount > 0 Then
				.MoveFirst
				iNumNode_Next = .Fields("NumStr")
			End If

			.Filter = "NumStr > '" & iNumNode_First & "' And NumStr < '" & iNumNode_Next & "'"

			If .RecordCount > 0 Then
				.MoveFirst
				Do Until .EOF
					sTempStr = sTempStr & Trim(.Fields("Line")) & " "
					.Delete
					.MoveNext
				Loop
			End If

			.Filter = ""
			.MoveFirst
			.Move iNumNode_First

			.Fields("Line") = String(.Fields("Space")," ") & Trim(.Fields("Line")) & Trim(sTempStr)
			.Update

		End With
	End If

	iNumNode_First = 0
	iNumLevel_First = 0
	iNumNode_Next = 0

	sTempStr =vbNullString

	sValue = "KEY"

	With objRSTextFile
		.Filter = "Line LIKE '" & sValue & " *'"
		If .RecordCount > 0 Then
			.MoveFirst
			iNumNode_First = .Fields("NumStr")
			iNumLevel_First = .Fields("LvlTree")

			sTempStr = Trim(.Fields("Line"))
			sTempStr = Mid(sTempStr, Instr(sTempStr, sValue) + Len(sValue))

			.Fields("Line") = String(.Fields("Space")," ") & sValue

		End If
	End With
	
	sTempSpace = vbNullString
	If iNumNode_First > 0 Then
		With objRSTextFile
			.Sort = "NumStr ASC"
			.Filter = "NumStr > '" & iNumNode_First & "' And LvlTree='" & iNumLevel_First + 1 & "'"
			If .RecordCount > 0 Then
				.MoveFirst
				sTempSpace = .Fields("Space")
				sTempStr = String(sTempSpace," ") & sTempStr
'msgbox sTempSpace
'msgbox sTempStr

			End If
		End With

		If sTempSpace <> vbNullString Then
			With objRSTextFile
				.Filter = ""
				.MoveFirst
				.Move iNumNode_First

'!!!!!! Вот на этом месте загвоздка (( !!!!

				.AddNew
				.Fields("Line") = sTempStr
				.Fields("Space") = sTempSpace
			End With
		End If
	End If

	Dim objExcel : Set objExcel = CreateObject("Excel.Application")

	With objExcel
		.DisplayAlerts = False
		.Visible = True
		.Workbooks.Add
	End With

	sSortColumn = vbNullString

	WriteRecordsetToExcel objRSTextFile, "Demo", sSortColumn 


'	objFile_New.Close
	objFile.Close
	Set objFile_New = Nothing
	Set objFile = Nothing

	Set objRSTextFile = Nothing
End If


'###############################################################################################################################
' Процедура быстрой сортировки массива (QuickSort)
' [in,out]    aArray - подлежащий сортировке массив
' [in]        aCompareFunction - функция-делегат для вычисления позиции элемента в результирующем массиве
'             должна иметь прототип SomeFunction(a, b) = <0, 0, >0 для сравнения a, b
Sub QuickSortArray(ByRef aArray, aCompare)

If Not IsArray(aArray) Then Exit Sub
    
If (UBound(aArray) < LBound(aArray)) Then Exit Sub
    
' А теперь отсортируем
QuickSortArrayPartial	aArray, _
			aCompare, _
			LBound(aArray), _
			UBound(aArray), _
			IsObject( aArray( LBound( aArray)))
End Sub

'###############################################################################################################################
' Процедура быстрой сортировки части массива (QuickSort)
' [in,out]    aArray - подлежащий сортировке массив
' [in]        aCompareFunction - функция-делегат для вычисления позиции элемента в результирующем массиве
'             должна иметь прототип SomeFunction(a, b) = <0, 0, >0 для сравнения a, b
' [in]        nLeft - первый элемент границ сортировки
' [in]        nRight - последний элемент границ сортировки
' [in]        bIsObject - признак работы с массивом объектов
Sub QuickSortArrayPartial(ByRef aArray, aCompare, nLeft, nRight, bIsObject)
    
Dim I, J, P, L, R, T
    
L = nLeft
R = nRight
    
Do
	I = L
	J = R
	If bIsObject Then
		Set P = aArray((L + R) \ 2)
	Else
		P = aArray((L + R) \ 2)
	End If
        
	Do
		While (aCompare(aArray(I), P) < 0)
			I = I + 1
		Wend
		While (aCompare(aArray(J), P) > 0)
			J = J - 1
		Wend
            
		If I <= J Then
			If bIsObject Then
				Set T = aArray(I)
				Set aArray(I) = aArray(J)
				Set aArray(J) = T
				Set T = Nothing
                	Else
				T = aArray(I)
				aArray(I) = aArray(J)
				aArray(J) = T
				T = Null
			End If
			I = I + 1
			J = J - 1
		End If
	Loop Until I > J
        
	If L < J Then _
		QuickSortArrayPartial aArray, aCompare, L, J, bIsObject

	L = I
Loop Until I >= R
End Sub

'###############################################################################################################################
' Функция - делегат для сравнения произвольных скалярных данных
Function Cmp_Any(a, b)

If a < b Then
	Cmp_Any = -1
ElseIf a > b Then
	Cmp_Any = 1
Else
	Cmp_Any = 0
End If      
End Function

'###############################################################################################################################
' Функция - делегат для сравнения произвольных строковых данных
Function Cmp_String(a, b)
	Cmp_String = StrComp(a, b)
End Function
'###############################################################################################################################

Sub WriteRecordsetToExcel(objRecordSet, sSheetsName, sSort)
	With objRecordSet
		.Filter = vbNullString
		If sSort <> vbNullString Then _
			.Sort = sSort 

		If .RecordCount > 0 Then




			objExcel.Sheets.Add().Name = sSheetsName

'			If Not Dict.Exists(sSheetsName) Then _
'				Dict.Add sSheetsName, objExcel.Sheets(sSheetsName).Index

			'objExcel.Sheets(objExcel.Sheets.Count).Select
			objExcel.Sheets(sSheetsName).Activate

			iRow = objExcel.Sheets(sSheetsName).UsedRange.Row + objExcel.Sheets(sSheetsName).UsedRange.Rows.Count - 1 
			iClm = objExcel.Sheets(sSheetsName).UsedRange.Column + objExcel.Sheets(sSheetsName).UsedRange.Columns.Count - 1

			objExcel.Sheets(sSheetsName).UsedRange.NumberFormat = "@"

			.MoveFirst
			i = 1
			For j = 0 To .Fields.Count - 1
				objExcel.Columns(j+1).Select
				objExcel.Selection.NumberFormat = "@"
				objExcel.Cells(i, j+1 ).Value = .Fields(j).Name
			Next

			i = i + 1
			Do Until .EOF
				For j = 0 To .Fields.Count - 1
					strVal = vbNullString
					If Not IsNull(.Fields(j).Value) Then _
						strVal = .Fields(j).Value
'					End If

					objExcel.Cells(i, j + 1 ).Value = strVal
				Next
				i = i + 1
				.MoveNext
			Loop
		End If


		objExcel.Sheets(sSheetsName).UsedRange.Interior.Pattern = xlNone
		objExcel.Sheets(sSheetsName).UsedRange.Interior.TintAndShade = 0
		objExcel.Sheets(sSheetsName).UsedRange.Interior.PatternTintAndShade = 0

		objExcel.Sheets(sSheetsName).UsedRange.Font.ColorIndex = xlAutomatic
		objExcel.Sheets(sSheetsName).UsedRange.Font.TintAndShade = 0
		objExcel.Sheets(sSheetsName).UsedRange.WrapText = True
		objExcel.Sheets(sSheetsName).UsedRange.ColumnWidth = 30
		objExcel.Sheets(sSheetsName).UsedRange.EntireColumn.AutoFit
		objExcel.Cells.EntireRow.AutoFit

		objExcel.Sheets(sSheetsName).UsedRange.AutoFilter '"", ""
'		objExcel.Sheets(sSheetsName).UsedRange.AutoFilter objExcel.Sheets(sSheetsName).UsedRange.Columns.Count - 1, "=207"
	End With
End Sub