取得字体的大小

I

import

Unregistered / Unconfirmed
GUEST, unregistred user!
以下的函数GetFontSizeList用来取得字体名为FontName的字体的所有可用尺寸,而EnumFontsSize是其中要用到的字体枚举回调函数:
function EnumFontsSize(var LogFont: TLogFont; var TextMetric: TTextMetric;
FontType: Integer; Data: Pointer): Integer; stdcall;
begin
TStrings( Data ).Add(IntToStr( LogFont.lfHeight) );
Result := 1;
end;
procedure GetFontSizeList( FontName : String; List : TStrings );
//FontName,是字体名;
//这种字体的所有可用尺寸将被填在List中。
var
DC: HDC;
begin
List.Clear;
DC := GetDC(0);
EnumFonts(DC, PChar(FontName), @EnumFontsSize, Pointer(List));
ReleaseDC(0, DC);
end;
///////////////////////////////////////////////////////////////////
var
Form1: TForm1;
VRES:Integer;
const
MaxStdSizes=16;
function EnumFontFamiliesProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
FontType: Integer; Data:pointer): Integer; {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF}
procedure AddToList(const aValue:String);
var
j:Integer;
c:Boolean;
begin
j:=0;
c:=False;
with TListBox(Data) do
begin
while (j<Items.Count) and not c do
if StrToInt(aValue)>=StrToInt(Items[j]) then Inc(j) else c:=True;
Items.Insert(j, aValue);
end;
end;
var
i:Integer;
c:String;
const
csizes:array[0..MaxStdSizes-1] of Integer=(8,9,10,11,12,14,16,18,20,22,24,26,28,36,48,72);
begin
result:=0;
with TListBox(Data) do
begin
if (FontType and TRUETYPE_FONTTYPE=TRUETYPE_FONTTYPE) or (FontType in [0,2]) then
begin
For i:=0 to (MaxStdSizes-1) do Items.Add(IntToStr(Csizes));
result:=0
end;
if (FontType and RASTER_FONTTYPE=RASTER_FONTTYPE)
{or (FontType and DEVICE_FONTTYPE=DEVICE_FONTTYPE)} then
with TextMetric do
begin
c:=IntToStr(Round((tmHeight-tmInternalLeading)*72 / VRES));
if Items.IndexOf(c)=-1 then AddToList(c);
result:=1;
end;
end
end;
procedure TForm1.DoList(FFontName:String);
var
buffer:array[0..255] of Char;
DC:HDC;
begin
ListBox1.Items.Clear;
DC:=GetDC(0);
StrPCopy(Buffer, FFontName);
vres:=GetDeviceCaps(DC, LOGPIXELSY);
EnumFontFamilies(DC, Buffer, @EnumFontFamiliesProc,
LongInt(ListBox1));
ReleaseDC(0, DC);
end;
 

Similar threads

I
回复
0
查看
457
import
I
I
回复
0
查看
414
import
I
S
回复
0
查看
794
SUNSTONE的Delphi笔记
S
S
回复
0
查看
797
SUNSTONE的Delphi笔记
S
I
回复
0
查看
418
import
I
顶部