uses commdlg; 
 
procedure FontDlg(fo: TFont); 
var 
  cf: tagCHOOSEFONTA; 
  lf: tagLOGFONTA; 
begin 
  zeromemory(@lf, sizeof(lf)); 
  zeromemory(@cf, sizeof(cf)); 
  cf.lStructSize := sizeof(tagCHOOSEFONTA); 
  cf.lpLogFont := @lf; 
  cf.flags := CF_BOTH or CF_EFFECTS or CF_INITTOLOGFONTSTRUCT or 
    CF_FORCEFONTEXIST; 
  cf.rgbColors := fo.color; 
  lf.lfheight := fo.height; 
  if fsbold in fo.style then 
    lf.lfweight := 700 else lf.lfweight := 400; 
  lf.lfitalic := ord(fsitalic in fo.style); 
  lf.lfunderline := ord(fsunderline in fo.style); 
  lf.lfstrikeout := ord(fsstrikeout in fo.style); 
  lf.lfcharset := fo.charset; 
  strpcopy(lf.lfFaceName, fo.name); 
  if ChooseFont(cf) then begin 
    fo.style := []; 
    fo.color := cf.rgbColors; 
    fo.name := lf.lfFaceName; 
    fo.charset := lf.lfcharset; 
    if lf.lfweight > 400 then fo.style := [fsbold]; 
    if lf.lfitalic = 1 then fo.style := fo.style + [fsitalic]; 
    if lf.lfunderline = 1 then fo.style := fo.style + [fsunderline]; 
    if lf.lfstrikeout = 1 then fo.style := fo.style + [fsstrikeout]; 
  end; 
end; 
 
// Beispielaufruf 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  FontDlg(Panel1.Font); 
end;

uses Winapi.CommDlg, System.UITypes; 
 
procedure FontDlg(fo: TFont); 
var 
  cf: TCHOOSEFONT; 
  lf: TLOGFONT; 
begin 
  zeromemory(@lf, sizeof(lf)); 
  zeromemory(@cf, sizeof(cf)); 
  cf.lStructSize := sizeof(cf); 
  cf.lpLogFont := @lf; 
  cf.flags := CF_BOTH or CF_EFFECTS or CF_INITTOLOGFONTSTRUCT or 
    CF_FORCEFONTEXIST; 
  cf.rgbColors := fo.color; 
  lf.lfheight := fo.height; 
  if fsbold in fo.style then 
    lf.lfweight := 700 
  else 
    lf.lfweight := 400; 
  lf.lfitalic := ord(fsitalic in fo.style); 
  lf.lfunderline := ord(fsunderline in fo.style); 
  lf.lfstrikeout := ord(fsstrikeout in fo.style); 
  lf.lfcharset := fo.charset; 
  strpcopy(lf.lfFaceName, fo.Name); 
  if ChooseFont(cf) then 
  begin 
    fo.style := []; 
    fo.color := cf.rgbColors; 
    fo.Name := string(lf.lfFaceName); 
    fo.charset := lf.lfcharset; 
    if lf.lfweight > 400 then 
      fo.style := [fsbold]; 
    if lf.lfitalic <> 0 then 
      fo.style := fo.style + [fsitalic]; 
    if lf.lfunderline <> 0 then 
      fo.style := fo.style + [fsunderline]; 
    if lf.lfstrikeout <> 0 then 
      fo.style := fo.style + [fsstrikeout]; 
    fo.size := lf.lfheight; 
    fo.charset := lf.lfcharset; 
  end; 
end; 
 
// Beispiel 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  FT: TFont; 
begin 
  FT := Label1.Font; 
  FT.Color := ColorToRGB(FT.Color); 
  FontDlg(FT); 
end;