Faster sorted list of OO font names

Shared Libraries
Forum rules
For sharing working examples of macros / scripts. These can be in any script language supported by OpenOffice.org [Basic, Python, Netbean] or as source code files in Java or C# even - but requires the actual source code listing. This section is not for asking questions about writing your own macros.
Post Reply
JeJe
Volunteer
Posts: 2763
Joined: Wed Mar 09, 2016 2:40 pm

Faster sorted list of OO font names

Post by JeJe »

Here is sorted list of OO font names... its faster than getting them from the sorted font descriptors one in Andrew Pitonyak's
helpful Fontmacro document.

Code: Select all


Option VBASupport 1

sub FontNames()
    dim FontList as collection, i as long
    FontList = new collection
   
    oWindow = ThisComponent.getCurrentController().getFrame().getContainerWindow()
    oFonts() = oWindow.getFontDescriptors()
   
    on error resume next 'add to collection, the error will stop duplicates being added

    For i = 0 to UBound(oFonts())
        FontList.add oFonts(i).name,oFonts(i).name
    Next

    FontList=sortCollection (FontList) 'then use a generic collection sort routine (below)

end sub

   'below 'generic collection sort routine not by me - from http://www.source-code.biz/snippets/vbasic/6.htm 
' good example of how VB6 code can be used in OO - this ran fine without modification
    ' This routine uses the "heap sort" algorithm to sort a VB collection.
    'Author: Christian d'Heureuse (www.source-code.biz, www.inventec.ch/chdh)
    'License: Free / LGPL

Public Function SortCollection(ByVal c As Collection) As Collection
    Dim n As Long: n = c.Count
    If n = 0 Then Set SortCollection = New Collection: Exit Function
    ReDim Index(0 To n - 1) As Long                    ' allocate index array
    Dim i As Long, m As Long
    For i = 0 To n - 1: Index(i) = i + 1: Next        ' fill index array
        For i = n \ 2 - 1 To 0 Step -1                    ' generate ordered heap
            Heapify c, Index, i, n
        Next
        For m = n To 2 Step -1                            ' sort the index array
            Exchange Index, 0, m - 1                        ' move highest element to top
            Heapify c, Index, 0, m - 1
        Next
        Dim c2 As New Collection
        For i = 0 To n - 1: c2.Add c.Item(Index(i)): Next  ' fill output collection
            Set SortCollection = c2
End Function

Private Sub Heapify(ByVal c As Collection, Index() As Long, ByVal i1 As Long, ByVal n As Long)
            ' Heap order rule: a[i] >= a[2*i+1] and a[i] >= a[2*i+2]
            Dim nDiv2 As Long: nDiv2 = n \ 2
            Dim i As Long: i = i1
            Do While i < nDiv2
                Dim k As Long: k = 2 * i + 1
                If k + 1 < n Then
                    If c.Item(Index(k)) < c.Item(Index(k + 1)) Then k = k + 1
                End If
                If c.Item(Index(i)) >= c.Item(Index(k)) Then Exit Do
                Exchange Index, i, k
                i = k
            Loop
End Sub

Private Sub Exchange(Index() As Long, ByVal i As Long, ByVal j As Long)
            Dim Temp As Long: Temp = Index(i)
            Index(i) = Index(j)
            Index(j) = Temp
End Sub
 
Windows 10, Openoffice 4.1.11, LibreOffice 7.4.0.3 (x64)
JeJe
Volunteer
Posts: 2763
Joined: Wed Mar 09, 2016 2:40 pm

Re: Faster sorted list of OO font names

Post by JeJe »

Here is the code adapted for a sorted list of font descriptors. It needs the same collection sort routine listed in the first post.
This using a collection method runs faster on my machine.

Code: Select all

Option VBASupport 1

Public sub FontDescriptors()

dim FontList as collection, FontListIndex as collection, i as long, j as long, c as long

	FontList = new collection
	FontListIndex = new collection
		
	oWindow = ThisComponent.getCurrentController().getFrame().getContainerWindow()
	oFonts() = oWindow.getFontDescriptors()
	
	on error resume next 'error will remove duplicates

	For i = 0 to UBound(oFonts())
		FontList.add oFonts(i).name, oFonts(i).name 'add names to collection
		FontListIndex.add i,oFonts(i).name 'index original location in oFonts
	Next

	FontList=sortCollection (FontList) 'generic collection sort of names

	c = fontlist.count
	oFinalFonts() = DimArray(c-1) 'redim array

	for i = 1 to c 'add to array using sorted collection and index collection
		oFinalFonts(j) = oFonts(FontListIndex.item(FontList.item(i)))
		j=j+1
	next

end sub
Windows 10, Openoffice 4.1.11, LibreOffice 7.4.0.3 (x64)
Post Reply