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) <> -1 AND Ubound(outline) <> -1 Then If (Ubound(outline) + 1) MOD (Ubound(heading) + 1 ) = 0 Then For i = 0 To (Ubound(outline)) oAnchor2Name = "Outline " + level + "." + (i Mod (Ubound(heading) + 1)) If i <= Ubound(heading) Then createAnchor(heading(i Mod (Ubound(heading) + 1)),oAnchor2Name) EndIf createLink(outline(i),"",oAnchor2Name) Next i Else MsgBox (getTranslation("TOCErrorContentsNotMatchHeadings1") & " " & level & " (" & (Ubound(outline)+1) & getTranslation("TOCErrorContentsNotMatchHeadings2") & " " & level & " " & getTranslation("TOCErrorContentsNotMatchHeadings3") & (Ubound(heading)+1) & ")" EndIf ElseIf Ubound(outline) = -1 Then ' MsgBox (getTranslation("TOCErrorNoContents1") & " " & level & " " & getTranslation("TOCErrorNoContents2")) ElseIf Ubound(heading) = -1 Then MsgBox (getTranslation("TOCErrorNoHeadings1") & " " & level & " " & getTranslation("TOCErrorNoHeadings2")) 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("com.sun.star.text.Paragraph") Then If enum1Element.OutlineLevel = curNum Then addToArray(headingPar(),enum1Element) EndIf ElseIf enum1Element.supportsService("com.sun.star.text.TextTable") 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("com.sun.star.text.Paragraph") 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 = "Contents " + curNum enum1 = ThisComponent.Text.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If enum1Element.ParaStyleName = parName Then addToArray(par(),enum1Element) EndIf ElseIf enum1Element.supportsService("com.sun.star.text.TextTable") 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("com.sun.star.text.Paragraph") Then If cellEnumElement.ParaStyleName = parName Then addToArray(par(),cellEnumElement) EndIf EndIf Wend Next i Else 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 > 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