Sujet Précédent Sujet Suivant

Utiliser sa propre fonte

Résolu
cincap Messages postés 460 Date d'inscription dimanche 5 décembre 2004 Statut Membre Dernière intervention 6 avril 2009 - 7 janv. 2007 à 10:34
cincap Messages postés 460 Date d'inscription dimanche 5 décembre 2004 Statut Membre Dernière intervention 6 avril 2009 - 8 janv. 2007 à 19:53
Bonjour à tous,

Est t'il possible d'utiliser une fonte *.ttf présente dans le répertoire de l'application et de l'appliquer dans le oncreate de la fiche au composant par ex : Tpanel.

On aurait "panel.fonte.name := mafonte.ttf" je pense !

Je connaissai ceci mais cela ne fonctionne pas :

AddFontResource(PChar(ExtractFilePath(Application.Exename)+'\mafonte.ttf'));
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

Si quelqu'un a une idée, je le remercie.

@+,

Cincap
[url]mailto:/url

4 réponses

Réponse 1 / 4
f0xi Messages postés 4205 Date d'inscription samedi 16 octobre 2004 Statut Modérateur Dernière intervention 12 mars 2022 35
8 janv. 2007 à 18:11
tiens voila un petit truc que j'avais codé y'a longtemps :


unitée ExtFontLoader :

unit ExtFontLoader;

interface

uses windows, sysutils, messages, forms, classes, graphics;

type
  TFontFileType = (ftTTF,ftFNT,ftFOT,ftTTC,ftFON);

  TFontLoader = class(TObject)
  private
     fFontList : TStringList;
     fOnChange : TNotifyEvent;
     function fGetCount : integer;
  protected
     procedure CallChange; virtual;
  public
     constructor Create;
     destructor Destroy; override;
     function  LoadFromFile(const FileName : string) : boolean;
     function  LoadFromResource(const FontName : string; const FontFileType : TFontFileType = ftTTF) : boolean;
     procedure FreeFonts;
     procedure CopyToList(List : TStrings);
     function GetFontPath(index : integer) : string;
     function GetFontHandle(index : integer) : cardinal;
     function GetFontName(index : integer) : string;
  published
     property Count : integer read fGetCount;
     property OnChange : TNotifyEvent read fOnChange write fOnChange;
  end;

implementation

uses FontsNameFunc;

{ ---- }

function GetTemporaryDir : string;
begin
  result := GetEnvironmentVariable('TMP');
  if length(result) < 3 then
     result := GetEnvironmentVariable('TEMP');
end;

function FFTToExt(const FontFileType : TFontFileType) : string;
begin
  case FontFileType of
    ftTTF : result := '.ttf';
    ftFNT : result := '.fnt';
    ftFOT : result := '.fot';
    ftTTC : result := '.ttc';
    ftFON : result := '.fon';
  end;
end;

function GetStrPart(const Str,Delimiter: String; const Index: cardinal = 1): String;
   function e_PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
   var I, X, Len, LenSubStr: Integer;
   begin
     if Offset = 1 then
        Result := Pos(SubStr,S)
     else begin
        I := Offset; LenSubStr := Length(SubStr);
        Len := Length(S)-LenSubStr+1;
        while I <= Len do begin
           if S[I] = SubStr[1] then begin
              X := 1;
              while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do Inc(X);
              if X = LenSubStr then begin
                 Result := I;
                 exit;
              end;
           end;
           Inc(I);
        end;
        Result := 0;
     end;
   end;
var I,P1,P2 : integer;
begin
  Result := '';
  if (e_posex(Delimiter,Str[1]) = 1) and (Index <= 1) then exit;
  P1 := 1;
  for I := 1 to Index-1 do begin
      P1 := e_posex(Delimiter, Str, P1);
      if P1 = 0 then exit
      else P1 := P1 + length(Delimiter);
  end;
  P2 := e_posex(Delimiter, Str, P1);
  if P2 = 0 then P2 := length(Str) + 1;
  Result := copy(Str, P1, P2 - P1);
end;

{ -------- }
{ -------- }

constructor TFontLoader.Create;
begin
  inherited create;
  fFontList := TStringList.Create;
  fFontList.Duplicates := dupIgnore;
end;

destructor TFontLoader.Destroy;
begin
  FreeFonts;
  fFontList.Free;
  inherited destroy;
end;

procedure TFontLoader.CallChange;
begin
  if Assigned(fOnChange) then fOnChange(Self);
end;

function TFontLoader.fGetCount : integer;
begin
  result := fFontList.Count;
end;

function TFontLoader.GetFontPath(index : integer) : string;
begin
  result := GetStrPart(fFontList.Strings[index],';',3);
end;

function TFontLoader.GetFontHandle(index : integer) : cardinal;
begin
  result := StrToIntDef(GetStrPart(fFontList.Strings[index],';',2),0);
end;

function TFontLoader.GetFontName(index : integer) : string;
begin
  result := GetStrPart(fFontList.Strings[index],';',1);
end;

function TFontLoader.LoadFromFile(const FileName : string) : boolean;
var idx     : integer;
    ftmp    : TFont;
    ftmphnd : cardinal;
    fntname : string;
begin
  result := false;
  if not FileExists(FileName) then exit;
  idx := AddFontResource(pchar(FileName));
  if idx = 0 then
     result := false
  else begin
     result := true;
     sendmessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
     FntName :=GetFontNameFromFile(FileName);
     FTmp := TFont.Create;
     FTmp.Name := FntName;
     fFontList.Add(FntName+';'+inttostr(FTmp.Handle)+';'+FileName);
     FTmp.Free;
  end;
  if result then
     CallChange;
end;

function TFontLoader.LoadFromResource(const FontName : string; const FontFileType : TFontFileType = ftTTF) : boolean;
var Res : TResourceStream;
begin
  try
    Res := TResourceStream.Create(0,FontName,RT_FONT);
    Res.SaveToFile(GetTemporaryDir+'_RTFONT_'+FontName+FFTToExt(FontFileType));
    result := LoadFromFile(GetTemporaryDir+'_RTFONT_'+FontName+FFTToExt(FontFileType));
  finally
    Res.Free;
  end;
end;

procedure TFontLoader.FreeFonts;
var i : integer;
    fn: string;
    rm: boolean;
begin
  rm := false;
  if fFontList.Count = 0 then exit;
  for i := 0 to fFontList.Count-1 do begin
      fn := GetFontPath(i);
      if FileExists(fn) then begin
         rm := RemoveFontResource(pchar(fn)) or rm;
         sendmessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
         if FileExists(fn) and (pos('_RTFONT_',fn) <> 0) then
            DeleteFile(fn);
      end;
  end;
  fFontList.Clear;
  if rm then begin
     CallChange;
  end;
end;

procedure TFontLoader.CopyToList(List : TStrings);
begin
  List.Assign(fFontList);
end;

end.


unité FontsNameFunc (code pas de moi) :

unit FontsNameFunc;

interface

uses
    Windows, SysUtils, Classes;

function GetFontNameFromFile(lpszFilePath: string): string;

implementation

type
    USHORT = Word;
    ULONG  = Longword;

type
    //  -----------------------------------------
    //  This is the TTF file header
    TT_OFFSET_TABLE = packed record
        uMajorVersion : USHORT;
        uMinorVersion : USHORT;
        uNumOfTables  : USHORT;
        uSearchRange  : USHORT;
        uEntrySelector: USHORT;
        uRangeShift   : USHORT;
    end;

    //  -----------------------------------------
    //  Tables in the TTF file and their placement and name (tag)
    TT_TABLE_DIRECTORY = packed record
        szTag         : array[0..3] of char;    //  table name
        uCheckSum     : ULONG;                  //  Check sum
        uOffset       : ULONG;                  //  Offset from beginning of file
        uLength       : ULONG;                  //  length of the table in bytes
    end;

    //  -----------------------------------------
    //  Header of the names table
    TT_NAME_TABLE_HEADER = packed record
        uFSelector    : USHORT;        //  format selector. Always 0
        uNRCount      : USHORT;        //  Name Records count
        uStorageOffset: USHORT;     //  Offset for strings storage, from start of the table
    end;

    //  -----------------------------------------
    //  Records in the names table
    TT_NAME_RECORD = packed record
        uPlatformID   : USHORT;
        uEncodingID   : USHORT;
        uLanguageID   : USHORT;
        uNameID       : USHORT;
        uStringLength : USHORT;
        uStringOffset : USHORT;     //  from start of storage area
    end;

//  ---------------------------------------------------------------------------
//  #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
function    SWAPWORD(x: Word): Word;
begin
    Result := MakeWord(HiByte(x), LoByte(x));
end;

//  ---------------------------------------------------------------------------
//  #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)),SWAPWORD(LOWORD(x)))
function    SWAPLONG(x: Cardinal): Cardinal;
begin
    Result := MakeLong(SWAPWORD(HiWord(x)), SWAPWORD(LoWord(x)));
end;

//  ---------------------------------------------------------------------------
function    GetFontNameFromFile(lpszFilePath: string): string;
var
    F: TFileStream;
    csRetVal: string;

    ttOffsetTable: TT_OFFSET_TABLE;

    Version: integer;

    tblDir: TT_TABLE_DIRECTORY;
    bFound: Boolean;
    i: integer;
    csTemp: string;

    ttNTHeader: TT_NAME_TABLE_HEADER;
    ttRecord: TT_NAME_RECORD;

    nPos: integer;
    Buf: array[0..1024] of char; //  ??...
begin
    //  lpszFilePath is the path to our font file
    F := TFileStream.Create(lpszFilePath, fmOpenRead or fmShareDenyWrite);
    try
        F.Read(ttOffsetTable, SizeOf(TT_OFFSET_TABLE));

        //  remember to rearrange bytes in the field you're going to use
        ttOffsetTable.uNumOfTables  := SWAPWORD(ttOffsetTable.uNumOfTables);
        ttOffsetTable.uMajorVersion := SWAPWORD(ttOffsetTable.uMajorVersion);
        ttOffsetTable.uMinorVersion := SWAPWORD(ttOffsetTable.uMinorVersion);

        //  check is this is a true type font and the version is 1.0
        Version := ttOffsetTable.uMajorVersion * 10 + ttOffsetTable.uMinorVersion;
        if (Version = 10) then
        begin
            bFound := false;

            for i := 0 to ttOffsetTable.uNumOfTables - 1 do
            begin
                //  the table's tag cannot exceed 4 characters
                F.Read(tblDir, SizeOf(TT_TABLE_DIRECTORY));
                csTemp := string(tblDir.szTag);
                if (LowerCase(csTemp) = 'name') then
                begin
                    //  we found our table. Rearrange order and quit the loop
                    bFound := true;
                    tblDir.uLength := SWAPLONG(tblDir.uLength);
                    tblDir.uOffset := SWAPLONG(tblDir.uOffset);
                    break;
                end;
            end;

            if (bFound) then
            begin
                //  move to offset we got from Offsets Table
                F.Seek(tblDir.uOffset, soFromBeginning);
                F.Read(ttNTHeader, SizeOf(TT_NAME_TABLE_HEADER));
                //  again, don't forget to swap bytes!
                ttNTHeader.uNRCount       := SWAPWORD(ttNTHeader.uNRCount);
                ttNTHeader.uStorageOffset := SWAPWORD(ttNTHeader.uStorageOffset);

                for i := 0 to ttNTHeader.uNRCount - 1 do
                begin
                    F.Read(ttRecord, SizeOf(TT_NAME_RECORD));
                    ttRecord.uNameID := SWAPWORD(ttRecord.uNameID);
                    //  1 says that this is the font name. 0, for example,
                    //  determines copyright info
                    if (ttRecord.uNameID = 1) then
                    begin
                        ttRecord.uStringLength := SWAPWORD(ttRecord.uStringLength);
                        ttRecord.uStringOffset := SWAPWORD(ttRecord.uStringOffset);
                        //  save file position so we can return to continue with search
                        nPos := F.Position;
                        F.Seek(tblDir.uOffset
                               + ttRecord.uStringOffset
                               + ttNTHeader.uStorageOffset,
                               soFromBeginning);

                        FillChar(Buf, SizeOf(Buf), 0);
                        F.Read(Buf, ttRecord.uStringLength);
                        csTemp := string(Buf);

                        //  yes, still need to check if the font name is not empty
                        //  if it is, continue the search
                        if (csTemp <> '') then
                        begin
                            csRetVal := csTemp;
                            break;
                        end;

                        F.Seek(nPos, soFromBeginning);
                    end;
                end;

            end;
        end;
    finally
        F.Free;
    end;

    Result := csRetVal;
end;

end.


Programme de test :

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    ListBox1: TListBox;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
uses ExtFontLoader;

{ -------- }
{ -------- }

var
  FontLoader : TFontLoader;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FontLoader := TFontLoader.Create;

  if FontLoader.LoadFromFile(ExtractFilePath(Paramstr(0))+'guevara.ttf') then begin
     Label1.Font.Name := 'Guevara';
     Label1.Font.Size := 16;
     Label1.caption   := 'ABCDEFGHabcdefgh '+inttostr(Label1.Font.Handle);
  end;

  if FontLoader.LoadFromFile(ExtractFilePath(Paramstr(0))+'blazed.ttf') then begin
     label2.Font.Name := 'Blazed';
     Label2.Font.Size := 16;
     Label2.caption   := 'ABCDEFGHabcdefgh '+inttostr(Label2.Font.Handle);
  end;

  FontLoader.CopyToList(ListBox1.Items);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FontLoader.Free;
end;

end.

3
Réponse 2 / 4
f0xi Messages postés 4205 Date d'inscription samedi 16 octobre 2004 Statut Modérateur Dernière intervention 12 mars 2022 35
8 janv. 2007 à 00:08
si il me semble bien :

var FontName : string = '';
    FontNum  : integer = 0;

procedure TForm1.FormCreate(Sender: TObject);

begin

  FontNum := AddFontResource(PChar(ExtractFilePath(ParamStr(0)) + 'font.TTF'));

  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  if FontNum <> 0 then begin
     FontName := Screen.Fonts.Strings[FontNum]; { ou [FontNum-1] }
     Self.Font.Name := FontName;
  end;

end;




procedure TForm1.FormDestroy(Sender: TObject);

begin

  RemoveFontResource(PChar(ExtractFilePath(ParamStr(0)) + 'font.TTF'));

  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

end;

0
Réponse 3 / 4
cincap Messages postés 460 Date d'inscription dimanche 5 décembre 2004 Statut Membre Dernière intervention 6 avril 2009 2
8 janv. 2007 à 08:13
Bonjour Foxi,

Merci de ta réponse, j'utilise le caption du Tpanel pour afficher la date et c'est la fonte de ce tpanel que je veux imposer.

La méthode proposée qui est pourtant logique semble ne pas permettre le choix de la fonte, car la propriété "Font.name" du Tpanel doit aussi indiquer la fonte utilisée, dans mon cas, j'avais mis "défaut".

Et à l'exécution elle affiche donc "défaut".

A mon avis il faut l'installer dans le répertoire "C:\Windows\Fonts" à la création de la fiche pour ensuite l'utiliser.

Merci encore,

Cincap
[url]mailto:/url
0
Réponse 4 / 4
cincap Messages postés 460 Date d'inscription dimanche 5 décembre 2004 Statut Membre Dernière intervention 6 avril 2009 2
8 janv. 2007 à 19:53
Bonsoir,

Merci pour ton temps, je vais essayer ton astuce dans les prochains jours.

@+,

Cincap

[url]mailto:/url
0

Discussions similaires

matrice, valeurs propres et vecteurs propres
SMarmotte -
libititi -

24 réponses
L’opération doit utiliser une requête qui peut être mise à jour
cs_meryamaa -
meryamaa -

8 réponses
calcul de vecteurs propres d'une matrice
cs_Nelene -
ASHHIM -

7 réponses
Envoi de fichiers via XMLHttpRequest
cs_ov3rdoze -
ov3rdoze -

9 réponses
Valeurs et vecteur propre en java
cs_ouafaa -
zedhadjer -

14 réponses
Rejoignez-nous