Zu jedem Font verfügbare Grösse ermitteln!

[R2009]

Hallo taaktaak,
danke dein Hinweis hat mir geholfen, das ist dabei rausgekommen:

Delphi-Quellcode:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  imin,imax:integer;   <<---hab ich auf die schnelle hinzugefügt. Hat im Original gefehlt
implementation

{$R *.dfm}
procedure GetSizes(var List:TStringlist;FontName:String;Min,Max:Integer);<<--- im Orginal
// list:tstrings hab ich durch var list:tstinglist ersetzt. Warum ist wohl klar

var DC : HDC; 
    LF : TLogFont; 

  function EnumSize(var LogFont:TLogFont;var TextMetric:TTextMetric; 
                    FontType:Integer;Data:LParam):Integer; stdcall; 
  const TTSizes : Array[0..15] of Integer 
                = (8,9,10,11,12,14,16,18,20,22,24,26,28,36,48,72);
  var   i,H     : Integer; 
        DC      : HDC; 
  begin 
   if FontType=TrueType_FontType then begin // get sizes from const array 
     for i:=0 to High(TTSizes) do 
       if TTSizes[i]>=iMin then 
         if TTSizes[i]<=iMax then 
           TStrings(Data).Add(IntToStr(TTSizes[i])); 
     Result:=0; 
     end 
                                 else begin // get sizes from WinAPI 
    DC:=GetDC(0); 

    try 
      with TextMetric do 
        H:=MulDiv(tmHeight-tmInternalLeading,72,GetDeviceCaps(DC,LogPixelsY)); 
        // 
        // folgende "Übersetzung" berechnet für Courier, 10 pts das falsche Ergebnis 9 pts 
        // ist also NICHT äquivalent zu MulDiv() 
        // 
        // H:=((tmHeight-tmInternalLeading)*72) div GetDeviceCaps(DC,LogPixelsY); 
        // 

      if H>=TTSizes[0] then // no smaller size than MinSize of TrueType 
        if H>=iMin then 
          if H<=iMax then 
            if TStrings(Data).IndexOf(IntToStr(H))<0 then 
              TStrings(Data).Add(IntToStr(H)); 
      Result:=1; 

    finally 
      ReleaseDC(0,DC); 
      end; 

    end; 

  end; 

  procedure SortList; 
  var i    : Integer; 
      t    : String; 
      Done : Boolean; 
  begin 
    repeat 
      Done:=true; 
      for i:=0 to List.Count-2 do 
        if StrToInt(List[i])>StrToInt(List[i+1]) then begin 
          t        :=List[i]; 
          List[i]  :=List[i+1]; 
          List[i+1]:=t; 
          Done     :=false; 
          end; 
      until Done 
  end; 

begin 
  DC:=GetDC(0); 

  iMin:=Min; 
  iMax:=Max; 
  if iMax=0 then iMax:=999; 

  try 
    fillchar(LF,SizeOf(LF),0); 
    LF.lfCharSet:=Default_CharSet; 
    Move(FontName[1],LF.lfFaceName,length(FontName)); 

    List.BeginUpdate; 
    List.Clear; 
    EnumFontFamiliesEx(DC,LF,@EnumSize,LParam(List),0); 
    Sortlist; 
    List.EndUpdate; 

  finally 
    ReleaseDC(0,DC); 
    end; 

end;

procedure TForm1.Button1Click(Sender: TObject);
var l:Tstringlist;
begin
  l:=tstringlist.Create;
  GetSizes(L,'Arial',0,100);
  ListBox1.Items.Assign(l);
  l.free;
end;

end.

Grüsse
Rainer

Ps: An alle die sich hier durch meine Reaktion "angemacht" oder ungerecht behandelt fühlen:
Es tut mir leid wenn ich jemanden ungerecht behandelt haben sollte.
War vielleicht der Frust darüber, dass man komplexeste Sachverhalte, in relativ kurzer Zeit, einfach lösen kann und
bei so einfachen Dingen wie der Fontgrösse fast kapitulieren muss.
Die unsachlichen Bemerkungen in diesem Thread möchte ich nicht kommentieren!