Tips (1541)

Tip Bewertung (11):

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;