Получить список CharSets, поддерживаемых шрифтом

type

   TNewTextMetricEx = packed
 record

     NewTextMetric: TNewTextMetric;
     FontSignature: TFontSignature
   end
;

   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));

 function
 EnumProc(const
 EnumLogFontEx: TEnumLogFontEx;
   const
 NewTextMetricEx: TNewTextMetricEx;
   FontType: Integer;
   Strings: TStrings): Integer; stdcall
;
 var

   I: Integer;
   ID: Integer;
   S: string
;
 begin

   ID := EnumLogFontEx.elfLogFont.lfCharSet;
   S  := Format('Unknown charset %d', [ID]);
   for
 I := 0 to
 NumCharSets - 1 do

     if
 CharSets[I].ID = ID then

     begin

       S := CharSets[I].Name;
       Break;
     end
;
   Strings.Add(S);
   Result := 1
 end
;

 procedure
 GetAvailableCharSets(const
 FaceName: string
; CharSets: TStrings);
 var

   DC: THandle;
   LogFont: TLogFont;
 begin

   DC := GetDC(GetDesktopWindow);
   if
 DC <> 0 then

     try

       FillChar(LogFont, SizeOf(LogFont), 0);
       Move(FaceName[1], LogFont.lfFaceName, Length(FaceName));
       LogFont.lfCharSet := DEFAULT_CHARSET;
       EnumFontFamiliesEx(DC, LogFont, @EnumProc, lParam(CharSets), 0);
     finally

       ReleaseDC(GetDesktopWindow, DC)
     end

 end
;


 procedure
 TForm1.Button1Click(Sender: TObject);
 begin

   Memo1.Clear;
   GetAvailableCharSets('Arial Narrow Bold', Memo1.Lines);
 end
;

Другое по теме:

• Как проинсталлировать свои шрифты
• Определение типа используемого шрифта
• PopupComponent и шрифты