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.