type
TCharSetRec = packed record
Name: String;
ID: Integer;
end;
const
NumCharSets = 19;
CharSets: array[0..NumCharSets - 1] of TCharSetRec = (
(Name: 'ANSI_CHARSET'; ID: 0),
(Name: 'DEFAULT_CHARSET'; ID: 1),
(Name: 'SYMBOL_CHARSET'; ID: 2),
(Name: 'SHIFTJIS_CHARSET'; ID: $80),
(Name: 'HANGEUL_CHARSET'; ID: 129),
(Name: 'GB2312_CHARSET'; ID: 134),
(Name: 'CHINESEBIG5_CHARSET'; ID: 136),
(Name: 'OEM_CHARSET'; ID: 255),
(Name: 'JOHAB_CHARSET'; ID: 130),
(Name: 'HEBREW_CHARSET'; ID: 177),
(Name: 'ARABIC_CHARSET'; ID: 178),
(Name: 'GREEK_CHARSET'; ID: 161),
(Name: 'TURKISH_CHARSET'; ID: 162),
(Name: 'VIETNAMESE_CHARSET'; ID: 163),
(Name: 'THAI_CHARSET'; ID: 222),
(Name: 'EASTEUROPE_CHARSET'; ID: 238),
(Name: 'RUSSIAN_CHARSET'; ID: 204),
(Name: 'MAC_CHARSET'; ID: 77),
(Name: 'BALTIC_CHARSET'; ID: 186));
procedure TForm1.Button1Click(Sender: TObject);
var
LogFont: TLogFont;
Fonthandle: HFont;
ID: Integer;
begin
//
Handle auf Schriftart ermitteln
Fonthandle := SendMessage(Control_Handle, WM_GETFONT, 0, 0);
FillChar(LogFont, SizeOf(LogFont), 0);
// LogFont Details ermitteln
GetObject(Fonthandle, SizeOf(logfont), @LogFont);
with LogFont do
begin
label1.Caption := StrPas(lffaceName); // Schriftname
label1.Height := -lfHeight; // Höhe
if lfWeight <> FW_MEDIUM then // Fett
if lfItalic <> 0 then // Kursiv
if lfUnderline <> 0 then // Unterstrichen
if lfStrikeout <> 0 then // Durchgestrichen
case (lfPitchAndFamily and 3) of
VARIABLE_PITCH: // fpVariable Schrift;
FIXED_PITCH: // fpFixed Schrift;
end;
ID := lfCharSet;
for I := 0 to NumCharSets - 1 do
if CharSets[I].ID = ID then begin
ShowMessage(CharSets[I].Name); // Charakterset anzeigen
Break;
end;
// usw...
end;
end;