procedure GetSizes(List:TStrings;FontName:
String;Min,Max:Integer);
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;