Storing Font information in the registry - with one key only

Problem/Question/Abstract:

Storing Font information in the registry - with one key only

Answer:

If you came in a situation to store font information in the registry, because you want to allow your users to customize your application, then you may have faced the fact that the TRegistry class does not provide WriteFont(), ReadFont() functions.

The first thought would be to make a sub key for each item in your application and write the font information as a combination of Strings and Integers.

WriteString(key, Font.FaceName);
WriteInteger(key, Font.Size);

Obviously not the most elegant code. Here's an elegant solution - store the font information as binary data! The Windows API provides a TLogFont structure that describes a font. It includes all properties that the Borland TFont class provides except the font's color. We'll use an extended logical description that contains the Windows (T)LogFont and the color. For information on TLogFont open help file Win32.hlp and search for LogFont.

// saves/ reads a font to/ from the registry
//
// read like this:
//   fEditorFont := TFont.Create;
//   fEditorFont.name := 'Courier New';
//   fEditorFont.Size := 10;
//   LoadFont(sKey, 'Editor', fEditorFont);
//
// and save like this:
//   SaveFont(sKey, 'Editor', fEditorFont);
unit sFontStorage;
interface
uses
  Graphics, Windows, Registry;

procedure LoadFont(const sKey, sItemID: string; var aFont: TFont);
procedure SaveFont(const sKey, sItemID: string; aFont: TFont);

implementation

type
  TFontDescription = packed record
    Color: TColor;
    LogFont: TLogFont;
  end;

procedure LoadFont(const sKey, sItemID: string; var aFont: TFont);
var
  iSiz: Integer;
  FontDesc: TFontDescription;
begin
  with TRegistry.Create do
  begin
    if OpenKey(sKey, False) then
    try
      iSiz := SizeOf(FontDesc);
      if ReadBinaryData(sItemID, FontDesc, iSiz) = SizeOf(FontDesc) then
      begin
        aFont.Handle := CreateFontIndirect(FontDesc.LogFont);
      end;
      aFont.Color := FontDesc.Color;
    finally
      CloseKey;
    end;
    // free the registry object
    Free;
  end;
end;

procedure SaveFont(const sKey, sItemID: string; aFont: TFont);
var
  iSiz: Integer;
  FontDesc: TFontDescription;
begin
  with TRegistry.Create do
  begin
    iSiz := SizeOf(FontDesc.LogFont);
    if GetObject(aFont.Handle, iSiz, @FontDesc.LogFont) > 0 then
    begin
      f OpenKey(sKey, True) then
        try
        FontDesc.Color := aFont.Color;
        WriteBinaryData(sItemID, FontDesc, SizeOf(FontDesc));
      finally
        CloseKey;
      end;
    end;
    // free the registry object
    Free;
  end;
end;

end.