Discussion :

[Jipété]

Bonjour,

Trouvé récemment ce petit bout de code Delphi mais on dirait que j'ai un souci d'énumération, regardez, en haut à gauche mon mémo, et dessous le snippet :


Bon, je n'ai pas essayé avec Arial Narrow Bold (je ne l'ai pas), mais les résultats sont identiques avec Arial, Arial Bold, Arial Rounded MT Bold et GNUtypewriter.

Alors bien sûr il m'a fallu adapter, en espérant que je ne casse pas quelque chose :
La proc de callback :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
function EnumCharSets(
  var LogFont: TEnumLogFontEx;
  var Metric: TNewTextMetricEx;
  FontType: Longint;
  //Strings: TStrings): Integer; stdcall; -- original mais ne compile pas
  Data: LParam):LongInt; stdcall;
var
  L: TStringList;
  S: String;
  I: Integer;
  ID: Integer;
begin
  L  := TStringList(ptrint(Data));
  ID := LogFont.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;
  L.Add(S);
//  Strings.Add(S); -- original
  result := 1;
end;

et son appel :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
procedure TForm1.GetAvailableCharSets(const FaceName: string; CharSets: TStrings);
var
  DC: THandle;
  LogFont: TLogFont;
////EDIT : sert à rien !  L: TStringList; // nouveau, inspiré d'un post sur FreePascal *
begin
////  L := TStringList.Create; // nouveau
//  DC := GetDC(GetDesktopWindow); -- proc inconnue sous Linux
  DC := GetDC(0);
  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, ptrint(lParam(CharSets)), 0); // changé sinon ne compile pas (ajout "ptrint")
////sert à rien !      CharSets.AddStrings(L); // ajout pour renvoyer les données au mémo
    finally
//      ReleaseDC(GetDesktopWindow, DC)
      ReleaseDC(0, DC)
    end
end;

Le problème, c'est qu'il est impossible de jouer en mode pas-à-pas avec une proc de callback, à chaque entrée le i du compteur de boucle est à 0...

Merci pour le coup de main,

---
* : http://forum.lazarus.freepascal.org/...?topic=20193.0