Сохранение свойств шрифтов

=== Сохранение свойств шрифтов ===
// Saving and restoring font properties in the registry
uses typInfo, Registry;
function GetFontProp(anObj: TObject): TFont;
var
 PInfo: PPropInfo;
begin
 { try to get a pointer to the property information for a property with the
 name 'Font'. TObject.ClassInfo returns a pointer to the RTTI table,
 which we need to pass to GetPropInfo }
 PInfo := GetPropInfo(anObj.ClassInfo, 'font');
 Result := nil;
 if PInfo <> nil then
 { found a property with this name, check if it has the correct type }
 if (PInfo^.Proptype^.Kind = tkClass)
 and GetTypeData(PInfo^.Proptype^)^.ClassType.InheritsFrom(TFont)
 then
 Result := TFont(GetOrdProp(anObj, PInfo));
end;
function StyleToString(styles: TFontStyles): string;
var
 style: TFontStyle;
begin
 Result := '[';
 for style := Low(style) To High(style) do
 begin
 if style in styles then
 begin
 if Length(Result) > 1 then
 Result := Result + ',';
 Result := Result + GetEnumname(TypeInfo(TFontStyle), Ord(style));
 end;
 end;
 Result := Result + ']';
end;
function StringToStyle(S: String): TFontStyles;
var
 sl: TStringList;
 style: TFontStyle;
 i: Integer;
begin
 Result := [];
 if Length(S) < 2 then Exit;
 if S[1] = '[' then
 Delete(S, 1, 1);
 if S[Length(S)] = ']' then
 Delete(S, Length(S), 1);
 if Length(S) = 0 then Exit;
 sl := TStringList.Create;
 try
 sl.CommaText := S;
 for i := 0 to sl.Count-1 do
 begin
 try
 style := TFontStyle(GetEnumValue(TypeInfo(TFontStyle), sl[i]));
 Include(Result, style);
 except
 end;
 end;
 finally
 sl.free
 end;
end;
procedure SaveFontProperties(forControl: TControl;
 toIni: TRegInifile; const section: string);
var
 font: TFont;
 basename: String;
begin
 Assert(Assigned(toIni));
 font := GetFontProp(forControl);
 if not Assigned(font) then Exit;
 basename := forControl.Name + '.Font.';
 toIni.WriteInteger(Section, basename + 'Charset', font.Charset);
 toIni.WriteString(Section, basename + 'Name', font.Name );
 toIni.WriteInteger(Section, basename + 'Size', font.Size );
 toIni.WriteString(Section, basename + 'Color', '$' + IntToHex(font.Color, 8));
 toIni.WriteString(Section, basename + 'Style', StyleToString(font.Style));
end;
procedure RestoreFontProperties(forControl: TControl;
 toIni: TRegInifile; const section: string);
var
 font: TFont;
 basename: String;
begin
 Assert(Assigned(toIni));
 font := GetFontProp(forControl);
 if not Assigned(font) then Exit;
 basename := forControl.Name + '.Font.';
 font.Charset := toIni.ReadInteger(Section, basename + 'Charset', font.Charset);
 font.Name := toIni.ReadString(Section, basename + 'Name', font.Name);
 font.Size := toIni.ReadInteger(Section, basename + 'Size', font.Size);
 font.Color := TColor(StrToInt(toIni.ReadString(Section, basename + 'Color', '$' + IntToHex(font.Color, 8))));
 font.Style := StringToStyle(toIni.ReadString(Section, basename + 'Style', StyleToString(font.Style)));
end;
It is also possible to wrap a font into a small component and stream it:
type
 TFontWrapper = class(TComponent)
 private
 FFont: TFont;
 constructor Create(AOwner: TComponent); override;
 destructor Destroy; override;
 procedure SetFont(Value: TFont);
 published
 property Font: TFont read FFont write SetFont;
 end;
{ TFontWrapper }
constructor TFontWrapper.Create(AOwner: TComponent);
begin
 inherited;
 FFont := TFont.Create;
end;
destructor TFontWrapper.Destroy;
begin
 FFOnt.Free;
 inherited;
end;
procedure TFontWrapper.SetFont(Value: TFont);
begin
 FFont.Assign(Value);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 helper: TFontWrapper;
begin
 if not Assigned(ms) then
 ms := TMemoryStream.Create
 else
 ms.Clear;
 helper := TFontWrapper.Create(nil);
 try
 helper.Font := Label1.Font;
 ms.WriteComponent(helper);
 finally
 helper.Free;
 end;
 Label1.Font.Size := Label1.Font.Size + 2;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
 helper: TFontWrapper;
begin
 if not Assigned(ms) then Exit;
 ms.Position := 0;
 helper := TFontWrapper.Create(nil);
 try
 ms.ReadComponent(helper);
 Label1.Font := helper.Font;
 finally
 helper.Free;
 end;
end;
ID: 01947
----
function FontToStr(font: TFont): string;
 procedure yes(var str: string);
 begin
 str := str + 'y';
 end;
 procedure no(var str: string);
 begin
 str := str + 'n';
 end;
begin
 { кодируем все атрибуты TFont в строку }
 Result := ;
 Result := Result + IntToStr(font.Color) + '|';
 Result := Result + IntToStr(font.Height) + '|';
 Result := Result + font.Name + '|';
 Result := Result + IntToStr(Ord(font.Pitch)) + '|';
 Result := Result + IntToStr(font.PixelsPerInch) + '|';
 Result := Result + IntToStr(font.Size) + '|';
 if fsBold in font.Style then
 yes(Result)
 else
 no(Result);
 if fsItalic in font.Style then
 yes(Result)
 else
 no(Result);
 if fsUnderline in font.Style then
 yes(Result)
 else
 no(Result);
 if fsStrikeout in font.Style then
 yes(Result)
 else
 no(Result);
end;
procedure StrToFont(str: string; font: TFont);
begin
 if str = then
 Exit;
 font.Color := StrToInt(tok('|', str));
 font.Height := StrToInt(tok('|', str));
 font.Name := tok('|', str);
 font.Pitch := TFontPitch(StrToInt(tok('|', str)));
 font.PixelsPerInch := StrToInt(tok('|', str));
 font.Size := StrToInt(tok('|', str));
 font.Style := [];
 if str[0] = 'y' then
 font.Style := font.Style + [fsBold];
 if str[1] = 'y' then
 font.Style := font.Style + [fsItalic];
 if str[2] = 'y' then
 font.Style := font.Style + [fsUnderline];
 if str[3] = 'y' then
 font.Style := font.Style + [fsStrikeout];
end;
function tok(sep: string; var s: string): string;
 function IsOneOf(c, s: string): Boolean;
 var
 iTmp: integer;
 begin
 Result := False;
 for iTmp := 1 to Length(s) do
 begin
 if c = Copy(s, iTmp, 1) then
 begin
 Result := True;
 Exit;
 end;
 end;
 end;
var
 c, t: string;
begin
 if s = then
 begin
 Result := s;
 Exit;
 end;
 c := Copy(s, 1, 1);
 while IsOneOf(c, sep) do
 begin
 s := Copy(s, 2, Length(s) - 1);
 c := Copy(s, 1, 1);
 end;
 t := ;
 while (not IsOneOf(c, sep)) and (s <> ) do
 begin
 t := t + c;
 s := Copy(s, 2, Length(s) - 1);
 c := Copy(s, 1, 1);
 end;
 Result := t;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 01948
----
Нужно сохранять атрибуты шрифта (имя, размер и т.п.) а не сам обьект TFont. После считывания этой информации следует проверить существует ли такой шрифт, прежде чем его использовать. Чтобы не показаться голословным дополню ответ Borland'а своим примером сохранения/чтения шрифта в/из реестра 
uses Registry;
procedure SaveFontToRegistry(Font: TFont; SubKey: string);
var
 R: TRegistry;
 FontStyleInt: byte;
 FS: TFontStyles;
begin
 R := TRegistry.Create;
 try
 FS := Font.Style;
 Move(FS, FontStyleInt, 1);
 R.OpenKey(SubKey, True);
 R.WriteString('Font Name', Font.Name);
 R.WriteInteger('Color', Font.Color);
 R.WriteInteger('CharSet', Font.Charset);
 R.WriteInteger('Size', Font.Size);
 R.WriteInteger('Style', FontStyleInt);
 finally
 R.Free;
 end;
end;
function ReadFontFromRegistry(Font: TFont; SubKey: string): boolean;
var
 R: TRegistry;
 FontStyleInt: byte;
 FS: TFontStyles;
begin
 R := TRegistry.Create;
 try
 Result := R.OpenKey(SubKey, false);
 if not Result then exit;
 Font.Name := R.ReadString('Font Name');
 Font.Color := R.ReadInteger('Color');
 Font.Charset := R.ReadInteger('CharSet');
 Font.Size := R.ReadInteger('Size');
 FontStyleInt := R.ReadInteger('Style');
 Move(FontStyleInt, FS, 1);
 Font.Style := FS;
 finally
 R.Free;
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 if FontDialog1.Execute then
 begin
 SaveFontToRegistry(FontDialog1.Font, 'Delphi Kingdom\Fonts');
 end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
 NFont: TFont;
begin
 NFont := TFont.Create;
 if ReadFontFromRegistry(NFont, 'Delphi Kingdom\Fonts') then
 begin // здесь добавить проверку - существует ли шрифт
 Label1.Font.Assign(NFont);
 NFont.Free;
 end;
end;
ID: 01949