epublishing/ePublishing/TOCLinks.xba

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="TOCLinks" script:language="StarBasic" script:moduleType="normal">Sub markTOC4
End Sub

Sub makeOutlineLinks
	Dim i As Integer
	For i = 1 To 10
		makeLinksWithLevel(i)
	Next i

End Sub


Sub makeLinksWithLevel(level)

	Dim heading() As Object
	Dim outline() As Object
	Dim oAnchor1Name As String
	Dim oAnchor2Name As String
	Dim i As Integer
	heading = getHeadingWithLevel(level)
	outline = getOutlineWithLevel(level)
	If  Ubound(heading) &lt;&gt; -1 AND Ubound(outline) &lt;&gt; -1 Then
		If (Ubound(outline) + 1) MOD (Ubound(heading) + 1 )  = 0 Then
			For i = 0 To (Ubound(outline))
				oAnchor2Name = &quot;Оглавление &quot; + level + &quot;.&quot; + (i Mod (Ubound(heading) + 1))
				If i &lt;= Ubound(heading) Then
					createAnchor(heading(i Mod (Ubound(heading) + 1)),oAnchor2Name)
				EndIf
				createLink(outline(i),&quot;&quot;,oAnchor2Name)
			Next i
		Else 
			MsgBox (&quot;Число Оглавлений &quot;+ level +&quot; уровня (&quot;+(Ubound(outline)+1) +&quot;) не кратно числу Заголовоков &quot; + level + &quot; уровня (&quot; + (Ubound(heading)+1) + &quot;)&quot;
		EndIf	
	ElseIf Ubound(outline) = -1 Then
		
		&apos;MsgBox (&quot;Не могу сделать ссылки в оглавлении. Оглавлений &quot;+ level + &quot; уровня не найдено.&quot;)
	ElseIf Ubound(heading) = -1 Then
		MsgBox (&quot;Не могу сделать ссылки в оглавлении. Заголовоков &quot;+ level + &quot; уровня не найдено.&quot;)
	EndIf
	
End Sub

Function getHeadingWithLevel(curNum)
	Dim enum1Element As Object
	Dim enum1 As Object
	Dim enum2 As Object
	Dim thisPortion As Object
	Dim footnoteText As Object
	Dim label As String
	Dim labelNum As Integer
	Dim i As Integer
	Dim count As Integer
	Dim cell As Object
	Dim cellEnum As Object
	Dim cellEnum2 As Object
	Dim headingPar() As Object
	enum1 = ThisComponent.Text.createEnumeration
	While enum1.hasMoreElements
		enum1Element = enum1.nextElement
		If enum1Element.supportsService(&quot;com.sun.star.text.Paragraph&quot;) Then
			If enum1Element.OutlineLevel = curNum Then
				 addToArray(headingPar(),enum1Element)
			EndIf
			
		ElseIf enum1Element.supportsService(&quot;com.sun.star.text.TextTable&quot;) Then
			cellNames = enum1Element.cellNames
			For i = LBound(cellNames) To Ubound(cellNames)
				cell = enum1Element.getCellByName(cellNames(i))
				cellEnum = cell.getText().createEnumeration()
				While cellEnum.hasMoreElements 
					cellEnumElement = cellEnum.nextElement
					If cellEnumElement.supportsService(&quot;com.sun.star.text.Paragraph&quot;) Then
						If cellEnumElement.OutlineLevel = curNum Then
				 			addToArray(headingPar(),cellEnumElement)
						EndIf
			
					EndIf
				Wend
		    Next i

		EndIf
	Wend 
	getHeadingWithLevel = headingPar()
End Function

Function getOutlineWithLevel(curNum)

	Dim enum1Element As Object
	Dim enum1 As Object
	Dim enum2 As Object
	Dim thisPortion As Object
	Dim footnoteText As Object
	Dim label As String
	Dim labelNum As Integer
	Dim i As Integer
	Dim count As Integer
	Dim cell As Object
	Dim cellEnum As Object
	Dim cellEnum2 As Object
	Dim par() As Object
	Dim parName As String
	Dim cellEnumElement As Object
	parName = &quot;Contents &quot; + curNum
	enum1 = ThisComponent.Text.createEnumeration
	While enum1.hasMoreElements
		enum1Element = enum1.nextElement
		If enum1Element.supportsService(&quot;com.sun.star.text.Paragraph&quot;) Then
			If enum1Element.ParaStyleName = parName Then
				 addToArray(par(),enum1Element)
			EndIf
			
		ElseIf enum1Element.supportsService(&quot;com.sun.star.text.TextTable&quot;) Then
			cellNames = enum1Element.cellNames
			For i = LBound(cellNames) To Ubound(cellNames)
				cell = enum1Element.getCellByName(cellNames(i))
				cellEnum = cell.getText().createEnumeration()
				While cellEnum.hasMoreElements 
					cellEnumElement = cellEnum.nextElement
					If cellEnumElement.supportsService(&quot;com.sun.star.text.Paragraph&quot;) Then
						If cellEnumElement.ParaStyleName = parName Then
				 			addToArray(par(),cellEnumElement)
						EndIf
			
					EndIf
				Wend
		    Next i
		Else 
			Mri enum1Element
		EndIf
	Wend 
	getOutlineWithLevel = par()
End Function

Sub addToArray(xArray(),vNextElement)
	Dim iUB As Integer
	Dim iLB As Integer
	iLB = lBound(xArray())
	iUB = uBound(xArray())
	If iLB &gt; iUB then
	   iUB = iLB
	   redim xArray(iLB To iUB)
	Else
	   iUB = iUB +1
	   redim preserve xArray(iLB To iUB)
	Endif
	xArray(iUB) = vNextElement
End Sub

</script:module>