Page 1 of 1

Faster sorted list of OO font names

PostPosted: Sun Feb 04, 2018 1:05 am
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   Expand viewCollapse view

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

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

end sub

   'below 'generic collection sort routine not by me - from
' 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 (,
    '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
        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
        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
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

Re: Faster sorted list of OO font names

PostPosted: Mon Feb 05, 2018 12:49 am
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   Expand viewCollapse view
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

   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)))

end sub