Listar fuentes en un archivo de Calc
From Apache OpenOffice Wiki
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 |