List fonts used in a document, search by font.

Question

Help! I cannot find a way to list, by name, of the fonts used (past tense) in a document. Like in the document properties: where the word and character count is.
Example: The author used Arial, Arial Condensed and OCR A in her document. I would like to see a list of three font names. If I have (or don't have) those fonts is outside the scope of this request.
Simply smashing the styles of a document and then restylng by hand is not working so well for me. Most of the documents used manual formatting instead of styles too!
Second: I can search and replace text if it had a font applied to it, but I cannot specify the font to search on. ANY font will be match and changed to the 'replace' style. Any solution?
Thanks!
John Fields

Answer 1

Interesting request and a bit of a programing challenge but here is what I have come up with. Try it on some of the documents that you need to deal with and let me know how it does.
Sub FontsUsed 'Version 1 John Vigor 4/25/06
'List fonts used in Writer document. Appears to work in normal text,
'Sections, normal Tables, and Frames. Will currently crash on a Table
'within a Table.
oDoc = ThisComponent
Dim fonts as Integer: Dim aFonts(1)
oTC = oDoc.Text.createTextCursor
oTC.goRight(1,true) : CurrentFont = oTC.charFontName
fonts = fonts + 1 : aFonts(fonts) = CurrentFont
REM Do "normal" text.
partEnum = oDoc.Text.createEnumeration
PartEnumerator(partEnum,CurrentFont,fonts,aFonts())
REM Do Frames.
oFrames = oDoc.getTextFrames
If oFrames.Count > 0 then
fonts = fonts + 1 : ReDim Preserve aFonts(fonts)
aFonts(fonts) = "NEW FONTS, IF ANY, FOUND IN FRAMES:"
For I = 0 to oFrames.Count - 1
  thisFrame = oFrames.getByIndex(I)
  partEnum = thisFrame.createEnumeration
  PartEnumerator(partEnum,CurrentFont,fonts,aFonts())
Next
EndIf
REM Prepare list.
For I = 1 to fonts
s = s & aFonts(I) & Chr(10)
Next
iAns = MsgBox(s,4,"FONTS FOUND. Create font list document?")
If iAns = 7 then
  End
Else
  NewDoc = StarDesktop.loadComponentFromURL("private:factory/swriter"," blank",O,Array())
  oVC = NewDoc.CurrentController.getViewCursor
  oVC.String = s : oVC.collapseToEnd
EndIf  
End Sub
Sub PartEnumerator(partEnum,CurrentFont,fonts,aFonts())
While partEnum.hasMoreElements
thisElement = partEnum.nextElement
If thisElement.supportsService("com.sun.star.text.Paragraph") then
   portionEnum = thisElement.createEnumeration
   PortionEnumerator(portionEnum,CurrentFont,fonts,aFonts())
  ElseIf thisElement. supportsService ("com.sun.star.text.TextTab le") then
   Cols = thisElement.getColumns.Count - 1
   Rows = thisElement.getRows.Count - 1
   For C = 0 to Cols
    For R = 0 to Rows
     thisCell = thisElement.getCellByPosition(C,R)
     cellEnum = thisCell.createEnumeration
     While cellEnum.hasMoreElements
      thisPara = cellEnum.nextElement
      portionEnum = thisPara.createEnumeration
      PortionEnumerator(portionEnum,CurrentFont,fonts,aFonts())
     Wend
    Next
   Next
EndIf
Wend
End Sub
Sub PortionEnumerator(portionEnum,CurrentFont,fonts,aFonts())
Dim found as Boolean
While portionEnum.hasMoreElements
thisPortion = portionEnum.nextElement
thisFont = thisPortion.charFontName
If thisFont <> CurrentFont then
  For I = 1 to fonts
   If aFonts(I) = thisFont then found = true: Exit For
  Next
  If found then
   CurrentFont = thisFont : found = false Else
   fonts = fonts + 1 : ReDim Preserve aFonts(fonts)
   aFonts(fonts) = thisFont : CurrentFont = thisFont
  EndIF
EndIf
Wend
End Sub