uses
{$ifdef windows}windows,{$endif}process, ...
...
{$ifdef windows}
function EnumFontsNoDups(
var LogFont: TEnumLogFontEx;
var Metric: TNewTextMetricEx;
FontType: Longint;
Data: LParam):LongInt; stdcall;
var
L: TStringList;
S: String;
begin
L := TStringList(ptrint(Data));
S := LogFont.elfLogFont.lfFaceName;
if L.IndexOf(S)<0 then
L.Add(S);
result := 1;
end;
procedure listlangfont(lang : String);
var
DC: HDC;
lf: TLogFont;
L: TStringList;
x: Integer;
begin
{
DEFAULT_PITCH = 0;
FIXED_PITCH = 1;
VARIABLE_PITCH = 2;
MONO_FONT = 8;
// font character sets
ANSI_CHARSET = 0;
DEFAULT_CHARSET = 1;
SYMBOL_CHARSET = 2;
// added for ISO_8859_2 under gtk
FCS_ISO_10646_1 = 4; // Unicode;
FCS_ISO_8859_1 = 5; // ISO Latin-1 (Western Europe);
FCS_ISO_8859_2 = 6; // ISO Latin-2 (Eastern Europe);
FCS_ISO_8859_3 = 7; // ISO Latin-3 (Southern Europe);
FCS_ISO_8859_4 = 8; // ISO Latin-4 (Northern Europe);
FCS_ISO_8859_5 = 9; // ISO Cyrillic;
FCS_ISO_8859_6 = 10; // ISO Arabic;
FCS_ISO_8859_7 = 11; // ISO Greek;
FCS_ISO_8859_8 = 12; // ISO Hebrew;
FCS_ISO_8859_9 = 13; // ISO Latin-5 (Turkish);
FCS_ISO_8859_10 = 14; // ISO Latin-6 (Nordic);
FCS_ISO_8859_15 = 15; // ISO Latin-9, or Latin-0 (Revised Western-European);
//FCS_koi8_r = 16; // KOI8 Russian;
//FCS_koi8_u = 17; // KOI8 Ukrainian (see RFC 2319);
//FCS_koi8_ru = 18; // KOI8 Russian/Ukrainian
//FCS_koi8_uni = 19; // KOI8 ``Unified'' (Russian, Ukrainian, and Byelorussian);
//FCS_koi8_e = 20; // KOI8 ``European,'' ISO-IR-111, or ECMA-Cyrillic;
// end of our own additions
MAC_CHARSET = 77;
SHIFTJIS_CHARSET = 128;
HANGEUL_CHARSET = 129;
JOHAB_CHARSET = 130;
GB2312_CHARSET = 134;
CHINESEBIG5_CHARSET = 136;
GREEK_CHARSET = 161;
TURKISH_CHARSET = 162;
VIETNAMESE_CHARSET = 163;
HEBREW_CHARSET = 177;
ARABIC_CHARSET = 178;
BALTIC_CHARSET = 186;
RUSSIAN_CHARSET = 204;
THAI_CHARSET = 222;
EASTEUROPE_CHARSET = 238;
OEM_CHARSET = 255;
}
lf.lfPitchAndFamily := 0;
if lang = 'ru' then lf.lfCharSet := 204 else
if lang = 'ar' then lf.lfCharSet := 178 else
if lang = 'he' then lf.lfCharSet := 177 else
if lang = 'el' then lf.lfCharSet := 161 else
if lang = 'zh' then lf.lfCharSet := 136 else
lf.lfCharSet := 1;
lf.lfFaceName := '';
L := TStringList.create;
L.Sorted := True;
L.Duplicates := dupIgnore;
x := 0;
DC := GetDC(0);
try
EnumFontFamiliesEX(DC, @lf, @EnumFontsNoDups, ptrint(L), 0);
L.Sort;
gridlistfont.rowcount := 0;
while x < L.count do
begin
gridlistfont.rowcount := gridlistfont.rowcount + 1;
gridlistfont[0][gridlistfont.rowcount - 1] := L[x];
inc(x);
end;
finally
ReleaseDC(0, DC);
L.Free;
end;
end;
{$endif}
{$ifdef unix}
procedure listlangfont(lang : String);
var
x, y: integer;
s, S2 : string;
comstr : ansistring;
sl: TStringList;
begin
comstr := '';
if fileexists('/usr/bin/fc-list') then
comstr := '/usr/bin/fc-list'
else
if fileexists('/usr/local/bin/fc-list') then
comstr := '/usr/local/bin/fc-list';
if comstr <> '' then
begin
sl := TStringList.create;
sl.Sorted := True;
sl.Duplicates := dupIgnore;
x := 0;
RunCommand(comstr, [':lang='+ lang, '--format=%{family[0]}\n'], s);
while (system.pos(lineend,s) > 0) do
begin
y := system.pos(lineend,s);
s2 := system.Copy(s, 1, y - 1);
//writeln(s2);
sl.Add(s2);
s := system.Copy(s, (y + 1) , length(s));
inc(x);
end;
//writeln('String lines ' + inttostr(x));
//writeln('TStringList ' + inttostr(sl.count));
x := 0;
while x < sl.count do
begin
gridlistfont.rowcount := x + 1;
gridlistfont[0][x] := string(sl[x]);
inc(x);
end;
sl.free;
end;
end;
{$endif}
Recent
