// Wer seinen eignen FontDialog programmieren will, könnte das so tun:
 

// Variante 1
// Getestet mit D4 unter WinME

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;

 

//--------------------------------------------------------------------

// Variante 2
// Getestet mit D2010 unter W7
// (minimale Ă„nderung)

procedure FontDlg(fo: TFont); 
var 
  cf: tagCHOOSEFONTA; 
  lf: tagLOGFONTA; 
  S: AnsiString; 
begin 
  S := AnsiString(fo.Name); 
  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, S); 
  if ChooseFontA(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 = 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;


Zugriffe seit 6.9.2001 auf Delphi-Ecke