| View previous topic :: View next topic |
| Author |
Message |
AndrewZ
Moderator
Joined: 21 Jun 2004
Posts: 4148
Location: Colorado, USA
|
 Posted: Tue Dec 07, 2004 6:33 am Post subject: Creates a text document with a sample of each font |
 |
|
It creates a text document with a sample of each font. The output is suitable for printing.
font sheet.sxw |
|
| Back to top |
|
 |
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 4021
Location: Lawrence, Kansas, USA
|
|
| Back to top |
|
|
AndrewZ
Moderator
Joined: 21 Jun 2004
Posts: 4148
Location: Colorado, USA
|
| Posted: Tue Dec 07, 2004 6:29 pm Post subject: |
|
|
| Code: |
REM ***** BASIC *****
'A BASIC program for OpenOffice.org that creates a text document with a sample of each available fonts
'Copyright (C) 2004 Andrew Ziem
'Some of this was derived from code to enumerate fonts from Paul Sobolik (psobolik@lycos.com)
'found in <http://www.pitonyak.org/AndrewMacro.sxw>.
'This program is free software; you can redistribute it and/or
'modify it under the terms of the GNU General Public License
'as published by the Free Software Foundation; either version 2
'of the License, or (at your option) any later version.
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
Sub Main
Dim mNoArgs()
Dim oTextDocument As Object
Dim oDesktop As Object
Dim sUrl As String
Dim oText As Object
Dim oCursor As Object
oDesktop = createUnoService("com.sun.star.frame.Desktop")
sUrl = "private:factory/swriter"
oTextDocument = oDesktop.loadComponentFromURL(sURL,"_blank", 0, mNoArgs())
oText = oTextDocument.Text
oCursor = oText.createTextCursor()
Dim oToolkit as Object
oToolkit = CreateUnoService("com.sun.star.awt.Toolkit")
Dim oDevice as Variant
oDevice = oToolkit.createScreenCompatibleDevice(0, 0)
Dim oFontDescriptors As Variant
oFontDescriptors = oDevice.FontDescriptors
Dim oFontDescriptor As Object
Dim sFontList as String
Dim iIndex as Integer, iStart As Integer, iTotal As Integer, iAdjust As Integer
iTotal = UBound(oFontDescriptors) - LBound(oFontDescriptors) + 1
iStart = 1
iAdjust = iStart - LBound(oFontDescriptors)
For iIndex = LBound(oFontDescriptors) To UBound(oFontDescriptors)
oFontDescriptor = oFontDescriptors(iIndex)
oCursor.charFontName = oFontDescriptor.Name
oCursor.CharFontPitch = oFontDescriptor.Pitch
oCursor.CharFontFamily = oFontDescriptor.Family
oCursor.CharWeight = oFontDescriptor.Weight
oCursor.CharPosture = oFontDescriptor.Slant
oText.insertString(oCursor, oFontDescriptor.Name, FALSE)
oCursor.charFontName = "Arial"
oCursor.CharWeight = 0
oCursor.CharPosture = 0
oText.insertString(oCursor, " (" & oFontDescriptor.Name, FALSE)
' oText.insertString(oCursor, " b:" & oFontDescriptor.Weight & " s:" & oFontDescriptor.Slant, FALSE)
If (100 < oFontDescriptor.Weight) Then
oText.insertString(oCursor, " bold", FALSE)
End If
If (com.sun.star.awt.FontSlant.OBLIQUE = oFontDescriptor.Slant) Then
oText.insertString(oCursor, " oblique" , FALSE)
End If
If (com.sun.star.awt.FontSlant.ITALIC = oFontDescriptor.Slant) Then
oText.insertString(oCursor, " italic", FALSE)
End If
oText.insertString(oCursor, ")", FALSE)
oCursor.charFontName = oFontDescriptor.Name
oCursor.CharWeight = oFontDescriptor.Weight
oCursor.CharPosture = oFontDescriptor.Slant
oText.insertControlCharacter(oCursor, LINE_BREAK, 0)
oText.insertString(oCursor, "The quick brown fox jumps over the lazy dog.", FALSE)
oText.insertControlCharacter(oCursor, APPEND_PARAGRAPH, 0)
Next iIndex
End Sub
|
|
|
| Back to top |
|
|
cwchia
Super User
Joined: 09 Jan 2003
Posts: 1063
Location: Malaysia
|
| Posted: Sat Apr 16, 2005 11:44 pm Post subject: |
|
|
I tried to use the macro in 1.9.93 but the resulted page is not sorted alphabetically like what happened in 1.1.4.
Why?  |
|
| Back to top |
|
|
AndrewZ
Moderator
Joined: 21 Jun 2004
Posts: 4148
Location: Colorado, USA
|
| Posted: Wed Apr 20, 2005 7:04 am Post subject: |
|
|
| cwchia wrote: | I tried to use the macro in 1.9.93 but the resulted page is not sorted alphabetically like what happened in 1.1.4.
Why? |
I can confirm that.
It seems that in OOo 1.1 the font list is provided sorted and this behavior changed in OOo 2. It would be necessary add function to sort the font list (but I don't plan more work on this script). |
|
| Back to top |
|
|
foxcole
Super User
Joined: 19 Jan 2006
Posts: 2771
Location: Minneapolis, Minnesota
|
| Posted: Tue Apr 04, 2006 8:15 pm Post subject: Re: Creates a text document with a sample of each font |
|
|
| ahz wrote: | It creates a text document with a sample of each font. The output is suitable for printing.
font sheet.sxw |
I like the fact that I can scan a few sheets of paper to find what I need. I rarely know the exact name of the font I'm looking for, so alphabetic sorting isn't all that critical for me.
Very nice snippet! Thank you!
_________________
Cheers!
---Fox
WinXP Pro SP2, OOo Portable 2.3.1, OOo local 2.4 RC4
New OpenOffice forum: http://user.services.openoffice.org/en/forum/
Manuals: http://documentation.openoffice.org/manuals/index.html |
|
| Back to top |
|
|
jrh
Newbie
Joined: 22 Apr 2006
Posts: 3
Location: Stokesley, N Yorks, UK
|
| Posted: Sat Apr 22, 2006 10:26 am Post subject: |
|
|
I am new to OOo macros (but familiar with VB) and decided to improve this code, as an exercise.
- The font names are sorted. (Illustrates sorting an array by sorting an auxiliary array of indices.) Actually, this is not perfect, eg if you change the font weight description " bold" to " Bold", it breaks collation between Lucida Sans and Lucida Sans Typewriter.
- Spell checking is disabled
- More use of subroutines to make the code clearer (at least, I think it helps)
- Blank line output between each font for clarity
| Code: |
REM ***** BASIC *****
'A BASIC program for OpenOffice.org that creates a text document with a sample of each available font
'Copyright (C) 2006 John Hunt
'Much of this was derived from code (C) 2004 Andrew Ziem found at
'<http://www.oooforum.org/forum/viewtopic.phtml?t=14900>.
'Some his code was derived from code to enumerate fonts from Paul Sobolik (psobolik@lycos.com)
'found in <http://www.pitonyak.org/AndrewMacro.sxw>.
'This program is free software; you can redistribute it and/or
'modify it under the terms of the GNU General Public License
'as published by the Free Software Foundation; either version 2
'of the License, or (at your option) any later version.
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
' Tested in OOo 2.0 under Mandriva Linux 2006
option explicit
Sub Main
const LINE_BREAK = 1
const APPEND_PARAGRAPH = 5
Dim oTextDocument As Object
Dim oDesktop As Object
Dim sUrl As String
Dim oText As Object
Dim oCursor As Object
dim sFullName as string, sNames as variant, vSortedIndex as variant, sLastFullName as string
dim sFontName as string, sLastFontName as string
oDesktop = createUnoService("com.sun.star.frame.Desktop")
sUrl = "private:factory/swriter"
oTextDocument = oDesktop.loadComponentFromURL(sURL, "_blank", 0, array())
oText = oTextDocument.Text
oCursor = oText.createTextCursor()
oCursor.CharHeight = 10
Dim oFontDescriptors As Variant
oFontDescriptors = getFontDescriptors()
Dim oFontDescriptor As Object
' disable spell checking
dim aLocale as new com.sun.star.lang.Locale
aLocale.Language = ""
aLocale.Country = ""
oCursor.CharLocale = aLocale
Dim i as Integer
' list all the font names
sNames = DimArray(UBound(oFontDescriptors) - LBound(oFontDescriptors)) ' zero based
For i = LBound(oFontDescriptors) To UBound(oFontDescriptors)
oFontDescriptor = oFontDescriptors(i)
with oFontDescriptor
sFullName = " (" & .Name
If (100 < .Weight) Then sFullName = sFullName & " bold"
If (com.sun.star.awt.FontSlant.OBLIQUE = .Slant) Then sFullName = sFullName & " oblique"
If (com.sun.star.awt.FontSlant.ITALIC = .Slant) Then sFullName = sFullName & " italic"
sFullName = sFullName & ")"
end with
sNames(i - LBound(oFontDescriptors)) = sFullName
next
' sort the font names
vSortedIndex = ArraySortIndexed(sNames)
' output font names and sample text in sorted order
For i = LBound(vSortedIndex) To UBound(vSortedIndex)
sFullName = sNames(vSortedIndex(i))
if sFullName <> sLastFullName then ' my Linux system lists some fonts twice
sLastFullName = sFullName
oFontDescriptor = oFontDescriptors(vSortedIndex(i))
with oFontDescriptor
sFontName = .Name
if sLastFontName <> sFontName and sLastFontName<>"" then
' leave some white space between fonts for legibility
SetArial(oCursor)
oText.insertControlCharacter(oCursor, APPEND_PARAGRAPH, 0)
endif
sLastFontName = sFontName
SetFont(oCursor, oFontDescriptor)
oText.insertString(oCursor, sFontName, FALSE)
SetArial(oCursor)
oText.insertString(oCursor, sFullName, FALSE)
oText.insertControlCharacter(oCursor, LINE_BREAK, 0)
SetFont(oCursor, oFontDescriptor)
oText.insertString(oCursor, TestChars(), FALSE)
SetArial(oCursor)
oText.insertControlCharacter(oCursor, APPEND_PARAGRAPH, 0)
end with
endif
Next i
End Sub
function getFontDescriptors() as variant
Dim oToolkit as Object
Dim oDevice as Variant
oToolkit = CreateUnoService("com.sun.star.awt.Toolkit")
oDevice = oToolkit.createScreenCompatibleDevice(0, 0)
getFontDescriptors = oDevice.FontDescriptors
end function
private sub SetArial(oCursor as object)
with oCursor
.charFontName = "Arial"
.CharWeight = 0
.CharPosture = 0
end with
end sub
private sub SetFont(oCursor as object, oFontDescriptors As Variant)
with oCursor
.charFontName = oFontDescriptors.Name
.CharWeight = oFontDescriptors.Weight
.CharPosture = oFontDescriptors.Slant
end with
end sub
private function TestChars() as string
static rslt as string
dim i as long
if rslt="" then
for i = 33 to 126
if chr(i) = "0" or ucase(chr(i)) = "A" then rslt = rslt & " "
rslt = rslt & chr(i)
if chr(i) = "9" or ucase(chr(i)) = "Z" then rslt = rslt & " "
next
rslt = rslt & " $£€ ßäé秿©®" ' some example specials
endif
TestChars = rslt
end function
' Sort an array. Array elements can be anything for which
' the > operator works. Returns an array of indices that when
' used to access the array put the array elements in order.
' The input array need not be zero based. The returned array is
' always zero based.
' Uses Shell sort; simple and much quicker than bubble sort.
function ArraySortIndexed(vaArray As Variant)as variant
Dim i As Long, iGap As Long, bNoExch As Boolean, iTemp As long
dim iUB as long, iLB as long
dim rslt as variant
iUB = UBound(vaArray, 1)
iLB = LBound(vaArray, 1)
if iUB - iLB + 1 = 0 then
rslt = array()
else
' dimarray cannot create an empty array, and is always zero based
rslt = DimArray(iUB - iLB)
endif
for i = iLB to iUB
rslt(i - iLB) = i
next
iGap = (iUB - iLB + 1) \ 2
Do
Do
bNoExch = True
For i = 0 To UBound(rslt) - iGap
If vaArray(rslt(i)) > vaArray(rslt(i + iGap)) Then
iTemp = rslt(i)
rslt(i) = rslt(i + iGap)
rslt(i + iGap) = iTemp
bNoExch = False
End If
Next
Loop Until bNoExch
iGap = iGap \ 2
Loop Until iGap = 0
ArraySortIndexed = rslt
End function
|
|
|
| Back to top |
|
|
andrewk8
Newbie
Joined: 28 Mar 2008
Posts: 1
|
| Posted: Fri Mar 28, 2008 6:32 pm Post subject: |
|
|
I tried both versions (Andrew Ziem's original and John Hunt's improved version). They both run and show the font names in their respective fonts. But what neither does is show the test string in the same font. In both cases, the test strings are shown in Arial.
I'm not a BASIC programmer, but I can figure out that the line "SetFont(oCursor, oFontDescriptor)" just before the test string should be setting the font, but it is obviously not working. What am I missing?
OpenOffice 2.3.0 under Ubuntu 7.10
_________________
--ACK |
|
| Back to top |
|
|
dysmas
Power User
Joined: 14 Apr 2007
Posts: 59
Location: Grenoble, France
|
| Posted: Sat Mar 29, 2008 9:30 am Post subject: |
|
|
it is a strange bug.
A workout is to change setFont to SetArial on line 96. Thus, the name of the font will be written in Arial, which is not the best thing, but the examples which are more important, will be written in the right font.
| Code: | SetArial(oCursor, oFontDescriptor)
oText.insertString(oCursor, sFontName, FALSE)
SetArial(oCursor)
oText.insertString(oCursor, sFullName, FALSE)
oText.insertControlCharacter(oCursor, LINE_BREAK, 0)
SetFont(oCursor, oFontDescriptor)
oText.insertString(oCursor, TestChars(), FALSE)
SetArial(oCursor)
oText.insertControlCharacter(oCursor, APPEND_PARAGRAPH, 0) |
I don't understand why this happens.
Tested on OO 2.3.0, windows 2000 Pro
_________________
Dysmas |
|
| Back to top |
|
|
whitejohn29
Newbie
Joined: 05 Jul 2008
Posts: 3
|
| Posted: Wed Jul 09, 2008 2:00 am Post subject: |
|
|
I studied very carefully your code but I do not understand why this line - rslt = rslt & " $�� ���秿��" is used. Can you explain me why you use such strange symbols?.
_________________
John, my web site is here |
|
| Back to top |
|
|
|
|
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum
|
Powered by phpBB © 2001, 2005 phpBB Group
|
