How to programmatically obtain information about font selection in Mathematica

Question

If I evaluate e.g. SystemDialogInput["Color"] and choose a colour, lets say red, the output cell shows RGBColor[1,0,0].

To view the font panel I can evaluate FrontEndTokenExecute["FontPanel"]. If I have some text highlighted somewhere I can change the font styling of the highlighted text (or cell) from the system panel that appears from the FrontEndTokenExecute. What I am wondering is if there is a way to programmatically return the chosen font settings analogous to how SystemDialogInput["Color"] returns the chosen color. For example, evaluate some code that includes choosing font settings within the system font panel, lets say manually choose Arial 12pt bold in the font panel,

and return e.g.

{FontFamily->"Arial",FontSize->12,FontWeight->Bold}

Just so we're clear I'm talking about doing this without any highlighted text or cell in the notebook. One of the problems seems to be -- on a Mac at least -- that the font is only selected if you have highlighted something in the notebook. There are some examples like this in the documentation (ref/CurrentValue):

Style["xxxx", FontFamily :> CurrentValue["ControlsFontFamily"], 
 FontSize :> CurrentValue["ControlsFontSize"]]

This suggest that an answer is possible if the appropriate argument to CurrentValue exists but "ControlsFontFamily" and "PanelFontFamily" are not the right arguments in this case.

Also is it possible to programmatically list all fonts available on a particular computer?

Edit

@kguler has provided an answer to the final sentence and second part of my question -- this could be used to build my own font panel. I have run @Heike's code and got this (screen grab) on Mac OS X 10.6.8 with Mma 8.0.4. Note the shadowing of PropertyValue with ref/PropertyValue.

Answer 1

I found this long time ago in MathGroup (but now I cannot find the exact link there).

fontlist = FE`Evaluate[FEPrivate`GetPopupList["MenuListFonts"]]

fontlist /. Rule[x_, y_] -> Style[x, 20, FontFamily -> y]

EDIT: The source is Wolfram's John Fultz. Here is the MathGroup link: V7 FrontEndTokens

EDIT 2: On windows, if you don't have a highlighted selection, the default seems to be whereever the cursor moves after the command FrontEndExecute[FrontEndToken["FontPanel"]] is executed. By default it is the next cell. Very first keyboard entry you type after the dialog return is styled with the font selection you make in the font dialog. So, if you execute

SelectionMove[InputNotebook[], After, Notebook]; 
 FrontEndExecute[FrontEndToken["FontPanel"]]

and start typing your font dialog settings will apply. However, any mouse move before a keyboard entry destroys the font settings.

EDIT 3: Using Silvia's idea about using an invisible notebook, but instead writing to a new cell in the current notebook also works. Steps: Move selection to a new cell that is closed, write something, invoke the font panel, capture the font options of the cell, delete the cell, and return the captured font options:

 fontPanelReturn[] := {SelectionMove[EvaluationNotebook[], After, Notebook]; 
   NotebookWrite[EvaluationNotebook[], Cell["text", ShowCellBracket -> False, 
                CellOpen -> False, Magnification -> 0]];
   SelectionMove[EvaluationNotebook[], Before, CellContents]; 
   SelectionMove[EvaluationNotebook[], All, Word]; 
   FrontEndExecute[FrontEndToken["FontPanel"]]; 
  fontops = 
   AbsoluteOptions[
         NotebookSelection[EvaluationNotebook[]], {FontColor, FontFamily, 
        FontProperties, FontSize, FontSlant, FontTracking, 
        FontVariations, FontWeight, Background}];
 NotebookDelete[EvaluationNotebook[]];
 SelectionMove[EvaluationNotebook[], Next, Cell]; fontops}

Using as

 fontPanelReturn[]

gives, (for example)

 {{Background -> None, FontColor -> Automatic, 
   FontFamily -> "Trebuchet MS", 
    FontProperties -> {"FontMonospaced" -> Automatic, 
    "FontSerifed" -> Automatic, "ScreenResolution" -> 72}, 
   FontSize -> 24, FontSlant -> "Italic", FontTracking -> "Plain", 
   FontVariations -> {"CapsType" -> Normal, 
   "CompatibilityType" -> Normal, "Masked" -> False, 
   "Outline" -> False, "RotationAngle" -> 0, "Shadow" -> False, 
   "StrikeThrough" -> False, "Underline" -> False}, 
   FontWeight -> "Bold"}}

EDIT 4: You get the same result if you change Silvia's code so that you select the cell before invoking the font panel dialog and then capturing the cell's font options (rather than the notebook's):

 inputFontSettings[] := 
    Module[{doc, opt}, 
    doc = CreateDocument[TextCell["text"], WindowSelected -> False, Visible -> False]; 
    SelectionMove[doc, Next, Cell]; 
    FrontEndTokenExecute[doc, "FontPanel"]; 
    opt = AbsoluteOptions[
    NotebookSelection[doc], {FontColor, FontFamily, FontProperties, 
    FontSize, FontSlant, FontTracking, FontVariations, FontWeight, 
    Background}]; NotebookClose[doc]; opt]

Answer 2

I think the example under Generalizations & Extentions on the help page for "FontChooser" in the documentation center does what you want. The code for that example is

Needs["GUIKit`"]

GUIRunModal[
 Widget["Panel", {
   Widget["FontChooser", {
     "showLogicalFonts" -> False,
     PropertyValue[{"chooser", "selectionModel"}, 
      Name -> "fontSelectionModel"], 
     BindEvent[{"fontSelectionModel", "change"},
      Script[updateFont[]]]
     }, Name -> "chooser"],
   Widget["TextField", {"text" -> ""}, Name -> "myTextField"],
   Script[
    fontExpr = {};
    updateFont[] := Module[{newFont},
      newFont = 
       PropertyValue[{"fontSelectionModel", "selectedFont"}];
      fontExpr = {
        FontFamily -> PropertyValue[{newFont, "family"}],
         FontSize -> PropertyValue[{newFont, "size"}], 
        FontWeight -> 
         If[PropertyValue[{newFont, "bold"}], "Bold", "Plain"], 
        FontSlant -> 
         If[PropertyValue[{newFont, "italic"}], "Italic", "Plain"]
        };
      SetPropertyValue[{"myTextField", "text"}, ToString[fontExpr]];
        ];
      ],
   BindEvent["endModal", Script[ fontExpr]]
   }]
 ] 

Answer 3

Maybe you can:

setup a invisible nb and put a sample textcell in it;

-> then select the cell;

-> using FrontEndTokenExecute["FontPanel"] to format it;

-> extract the font options you need from the cellexpression;

-> paste it to where you want.

---

Here's how to implement this:

inputFontSettings[] :=
 Module[
  {doc, opt},
  doc = CreateDocument[TextCell["text"], WindowSelected -> False, Visible -> False];
  SelectionMove[doc, All, Notebook];
  FrontEndTokenExecute[doc, "FontPanel"];
  opt = Options@NotebookRead[doc];
  NotebookClose[doc];
  opt
 ]

Note that if use keep the default font size, no FontSize item will be returned.

Answer 4

On the question of listing all available fonts...

Hopefully someone will chime in soon with a native Mathematica way to get a list of all available fonts. While we wait, here is a way using Java:

Needs["JLink`"]
LoadJavaClass["java.awt.GraphicsEnvironment"];

fontFamilies[] :=
  JavaBlock @
    java`awt`GraphicsEnvironment`getLocalGraphicsEnvironment[] @ 
      getAvailableFontFamilyNames[]

The Java list might not match the Mathematica list exactly given the technology differences, but it is a decent start.