procedure FontToStream(F: TFont; S: TStream); 
var 
  b: byte; 
  i: integer; 
  n: string; 
  function FontStyleToByte(fs: TFontStyles): byte; 
  begin 
    move(fs, result, 1); 
  end; 
begin 
  with F do begin 
    b := Charset; 
    S.writebuffer(b, 1); 
    i := color; 
    S.writebuffer(i, 4); 
    i := height; 
    S.writebuffer(i, 4); 
    b := FontStyleToByte(style); 
    S.writebuffer(b, 1); 
    n := Name; 
    i := length(n); 
    S.writebuffer(i, 4); 
    S.writebuffer(n[1], i); 
  end; 
end; 
 
procedure StreamToFont(S: TStream; F: TFont); 
var 
  b: byte; 
  i: integer; 
  n: string; 
  function ByteToFontStyle(bt: byte): TFontStyles; 
  begin 
    move(bt, result, 1); 
  end; 
begin 
  with F do begin 
    S.readbuffer(b, 1); 
    Charset := b; 
    S.readbuffer(i, 4); 
    color := i; 
    S.readbuffer(i, 4); 
    height := i; 
    S.readbuffer(b, 1); 
    style := ByteToFontStyle(b); 
    S.readbuffer(i, 4); 
    setlength(n, i); 
    S.readbuffer(n[1], i); 
    Name := n; 
  end; 
end; 
 
 
// Beispielaufruf 
 
// schreiben und ändern 
 
procedure TForm1.Button8Click(Sender: TObject); 
var 
  Str: TFileStream; 
begin 
  Str := TFileStream.create('Font.Str', fmCreate); 
  FontToStream(Font, Str); 
  Str.free; 
 
  Font.Style := [fsitalic]; 
  Font.Size := 16; 
  Font.Name := 'Courier New'; 
end; 
 
 
// lesen und zurücksetzen 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  Str: TFilestream; 
begin 
  if FileExists('Font.Str') then begin 
    Str := TFileStream.create('Font.Str', fmOpenRead); 
    StreamToFont(Str, Font); 
    Str.free; 
  end else showmessage('"Font.Str" nicht gefunden.'); 
end;