Schriftartenermittlung

[Crowbar]

Hallo,
ich möchte ein Programm schreiben, dass im Hintergrund läuft und folgende Aufgabe hat:
Es soll aus einem gerade aktivem Fenster (eines fremden Programmes) den gerade benutzten Zeichensatz herausfinden (z.B. in einem Schreibprogramm oder in einem Eingabefeld)?

Vielen Dank für Euere Hilfe...
Crowi

[Luckie]

Hm,
das hatte ich schon mal gelöst mit jemanden. Du brauchst auf alle Fälle ein DC auf das Kontroll. Und dann kann man die Schrift mit einer API-Funktion auslesen/ermitteln. Frag mich aber nicht nach der API-Funktion, GetObject oder so.

[toms]

Hi,

Mit WM_GETFONT bekommst du dass Handle auf eine Schriftart.
Über GetObject() und TLogFont bekommst du dann die Details dieser Schrift.

Beispiel:

Code:

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;

[Luckie]

Ich wußte doch, dass mich mein Gedächnis nicht im Stich läßt. Na ja - fast jeden falls.