Listar fuentes en un archivo de Calc

La siguientes macros están basadas en la que muestra Andrew Pitonyak en su excelente libro de macros (ver Bibliografía); en el original se muestran los nombres de las fuentes en un cuadro de mensaje. Con unos pequeños cambios las mostramos en un archivo nuevo de Calc.

Las dos son muy parecidas. Esta primera te muestra el nombre de la fuente junto con los estilos o variantes que soporta.

 'Original de Andrew Pitonyak
 'Estas versiones Mauricio Baeza
 Sub ListarFuentes1()
 Dim oToolkit As Object
 Dim oDevice As Object
 Dim oFontDescriptors As Object
 Dim co1 As Long
 Dim mArg()
 Dim oNuevoDocumento As Object
 Dim Campos(0) As New com.sun.star.table.TableSortField
 Dim aSD(0) As New com.sun.star.beans.PropertyValue
 
     oToolkit = CreateUnoService("com.sun.star.awt.Toolkit")
     oDevice = oToolkit.createScreenCompatibleDevice(0, 0)
     oFontDescriptors = oDevice.FontDescriptors()
 
     oNuevoDocumento = StarDesktop.loadComponentFromURL( "private:factory/scalc", "_default", 0, mArg() )
     With oNuevoDocumento.getSheets().getByIndex(0)
         .getCellByPosition(0,0).setString( "Nº" )
         .getCellByPosition(1,0).setString( "Fuente" )
         For co1 = LBound(oFontDescriptors) To UBound(oFontDescriptors)
             .getCellByPosition(0,co1+1).setValue( co1+1 )
             .getCellByPosition(1,co1+1).setString( oFontDescriptors(co1).Name & " " & oFontDescriptors(co1).StyleName )
         Next
         Campos(0).Field = 0
         Campos(0).IsAscending = True
         aSD(0).Name = "SortFields"
         aSD(0).Value = Campos()
         .getCellRangeByName( "B1:B" & CStr(co1+1) ).sort( aSD() )
         .getCellRangeByName("A1:B1").getColumns().OptimalWidth = True
     End With
 End Sub

La segunda es similar, excepto que solo te muestra el nombre de la fuente, sin variantes, esto es por que la mayoría de estas variantes las establecemos por código con otros métodos y propiedades (negrita, cursiva, etc).

 Sub ListarFuentes2()
 Dim oToolkit As Object
 Dim oDevice As Object
 Dim oFontDescriptors As Object
 Dim co1 As Long
 Dim mArg()
 Dim oNuevoDocumento As Object
 Dim oFD As Object
 Dim oCursor As Object
 Dim Campos(0) As New com.sun.star.table.TableSortField
 Dim aSD(0) As New com.sun.star.beans.PropertyValue
 
     oToolkit = CreateUnoService("com.sun.star.awt.Toolkit")
     oDevice = oToolkit.createScreenCompatibleDevice(0, 0)
     oFontDescriptors = oDevice.FontDescriptors()
 
     oNuevoDocumento = StarDesktop.loadComponentFromURL( "private:factory/scalc", "_default", 0, mArg() )
     With oNuevoDocumento.getSheets().getByIndex(0)
         .getCellByPosition(0,0).setString( "Fuente" )
         For co1 = LBound(oFontDescriptors) To UBound(oFontDescriptors)
             .getCellByPosition(0,co1+1).setString( oFontDescriptors(co1).Name )
         Next
 
         'Con un filtro obtenemos registros únicos en la columna C
         oFD = .getCellRangeByName( "A1:A" & CStr(co1+1) ).createFilterDescriptor( True )
         oFD.SkipDuplicates = True
         oFD.ContainsHeader = True
         oFD.CopyOutputData = True
         oFD.OutputPosition = .getCellByPosition(2,0).getCellAddress()
         .getCellRangeByName( "A1:A" & CStr(co1+1) ).filter( oFD )
 
         'Eliminamos los datos originales, columna A
         .getColumns().removeByIndex(0,1)
 
         'Como filtramos, averiguamos cuantas filas quedaron
         oCursor = .createCursorByRange( .getCellByPosition(1,0) )
         oCursor.collapseToCurrentRegion()
 
         'Ordenamos los nombres de las fuentes
         Campos(0).Field = 0
         Campos(0).IsAscending = True
         aSD(0).Name = "SortFields"
         aSD(0).Value = Campos()
         .getCellRangeByName( "B1:B" & CStr(oCursor.getRows.getCount) ).sort( aSD )
 
         'Insertamos la numeracion de las fuentes
         .getCellByPosition(0,0).setString( "Nº" )
         .getCellByPosition(0,1).setValue( 1 )
         .getCellRangeByName("A2:A" & CStr(oCursor.getRows.getCount) ).fillAuto( 0, 1 )
 
         'Autoajustamos el ancho de las columnas
         .getCellRangeByName("A1:B1").getColumns.OptimalWidth = True
     End With
 
 End Sub

Si tienes dudas acerca de lo aquí explicado, tienes algún problema con AOO, o quieres ampliar la información, no dudes en dirigirte al Foro Oficial en español de Apache OpenOffice para Macros y API UNO