Determine language of font RRS feed

  • Question

  • Hello all experts,

    Recently I've come across several macrosto print samples of all fonts installed on local machine, they loop thru all installed fonts and type a sample text for each one, the problem is that if the font doesn't support english (the language of the sample text) boxes show-up instead of the letters, us there a way to detect what language each font suports? If its possible then for a different language font I can have it type text in a supported language.

    Here is one of the macros:

    Sub FontSamples()
      ' Samples all fonts installed
      ' Macro written 31 March 2006 by John McGhie
      Const SampleText As String = "the quick brown fox jumps over the lazy dog." & _
          " THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 0 1 2 3 4 5 6 7 8 9"
      Dim i As Long
      ' Make our own array because FontNames is FUBARed
      Dim AllFonts() As String
      Dim StyDoc As Document
      Set StyDoc = Application.Documents.Add
       ' Resize the array the way we want it (in case the user has an Option Base set)
      ReDim AllFonts( 1 To FontNames.Count)
      ' Load the array one by one from FontNames
      For i = 1 To FontNames.Count
        AllFonts(i) = FontNames(i)
      Next i
      ' Use the WordBasic sort because VBA doesn't have one!!
      WordBasic.SortArray AllFonts$()
      ' Adjust the styles we want to use in the document we just created
      With StyDoc.Styles
        With .Item(wdStyleHeading1)
          .Font.Color = wdColorBlue
          .ParagraphFormat.PageBreakBefore = False
        End With
        With .Item(wdStyleBodyText)
          .Font.Size = 36
          .Font.Color = wdColorAutomatic
        End With
      End With
      ' Add a TOC so we can list the styles and find them later
      With StyDoc.TablesOfContents
        .Add Range:=Selection.Range, RightAlignPageNumbers:= _
            True , UseHeadingStyles:= True , UpperHeadingLevel:= 1 , _
            LowerHeadingLevel:= 1 , IncludePageNumbers:= True , AddedStyles:= ""
        .Item( 1 ).TabLeader = wdTabLeaderDots
        .Format = wdIndexIndent
      End With
       ' there's a bug in FontNames collection, in WD2003 we can't
       ' use For Each ... Next, it errors due to a type mismatch
      For i = 1 To UBound (AllFonts)
        With Selection
          .Style = wdStyleHeading1
          .TypeText Text:=AllFonts(i)
          .Style = wdStyleBodyText
          .Font.Name = AllFonts(i)
          .TypeText Text:=SampleText
        End With
      Next i
      StyDoc.TablesOfContents( 1 ).Update
      Selection.HomeKey Unit:=wdStory, Extend:=wdMove 
    End Sub

    Here are links to someother macros to accomplish the same:;en-us;209205

    • Edited by moishy Monday, February 20, 2012 7:07 AM
    Monday, February 20, 2012 5:33 AM

All replies