Ce petit programme montre comment créer des polices a partir d'une bitmap.
il y a deux polices de fournies avec le code :
POLICE.BMP et POLICE-INT.BMP
Source / Exemple :
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,jpeg, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
Edit1: TEdit;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure FormPaint(Sender: TObject);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
Form1: TForm1;
base:Tbitmap;
Police:Array[32..92]of Tbitmap;
T: TPicture;
Xpos,ypos:integer;
ind:integer;
IMG:Array[0..100]of Timage;
Procedure Charger_Police(F : String);
implementation
{$R *.DFM}
{*** Bon, je vais faire un effort sur les commentaires cette fois ! ***}
{*** Cette procédure remplit (d'où son nom) la fenêtre avec
l'image chargée dans "T" (TPicture) et boucle sur les bords autant
de fois que nécessaire (étirez la feuille, vous verrez qu'elle est texturée
partout quelque soit sa taille) ***}
procedure remplir;
var
xp,
yp : integer;
begin
xp := 0;
yp := 0;
repeat
repeat
Form1.Canvas.draw( xp, yp, T.Graphic );
xp := xp + t.Width;
until xp > Form1.Width;
xp :=0 ;
yp := yp + t.Height;
until yp > Form1.height;
end;
{*** Dans le FormCreate :
On charge la texture de fond
On initialise le tableau qui contiendra la police
On charge la police par défaut si elle existe ***}
procedure TForm1.FormCreate(Sender: TObject);
var
n:byte;
begin
T := TPicture.Create;
If FileExists('FOND.BMP')
Then T.LoadFromFile('FOND.BMP')
Else Begin
ShowMessage('Impossible d''ouvrir le fichier FOND.BMP');
Application.Terminate;
End;;
Base:=Tbitmap.Create;
Base.height:=16;
Base.Width:=976; {*** 976 = 16 * 61 caractères ***}
For n:=32 to 92 do begin
Police[n]:=Tbitmap.Create;
Police[n].Height:=16;
Police[n].Width:=16;
end;
xpos:=0;
ypos:=0;
ind:=0;
{*** S'il le fichier POLICE.BMP n'existe pas il faudra le chercher à la main ***}
If FileExists('POLICE.BMP') Then Charger_Police('POLICE.BMP');
end;
{*** Chargement de la police, bien entendu le seul paramètre c'est le nom du
fichier.
Cette procédure "saucissone" l'image BASE en morceaux de 16*16 et les range
dans le tableau POLICE initialisé dans le FormCreate.
Si vous créez une police, faites gaffe que les caractères ne dépassent pas
16*16 ***}
Procedure Charger_Police(F : String);
var
n,v:byte;
t:string;
Begin
Base.LoadFromFile(F);
For v:=32 to 92 do
begin
n:=v-32;
Police[v].Canvas.copyrect(rect(0,0,16,16),base.Canvas,rect(n*16,0,(n+1)*16,16))
End;
n:=Length(F);
Repeat
v:=n;
dec(n);
until F[n]=#92;
t:=copy(F,v,(length(F)-3)-v);
Form1.caption:=T;
Form1.EDIT1.Enabled := True;
End;
{*** Charger une police grâce a un controle OpenDialog ***}
procedure TForm1.Button1Click(Sender: TObject);
begin
if Form1.OpenDialog1.execute then
If FileExists(OpenDialog1.Filename) Then Charger_Police(OpenDialog1.FileName);
If Edit1.Enabled Then Edit1.SetFocus;
end;
{*** Traiter les entrées de EDIT1
Le programme traite le caractère ascii et le transforme en index du tableau
POLICE (facile, si on crée la police dans l'ordre des codes ascii !!!
Pour eviter de s'ennuyer avec des minuscules, tout est passé en majuscule (UpCase)
Le programme crée donc une image IMGS a partir de POLICE et la place au bon endroit.
Si l'utilisateur fait delete, la dernière image créée et detruite (sauf si
on est sur une nouvelle ligne)
Si l'utilisateur fait entrée, Le programme met la coordonnée horizontale à 0
et ajoute 16 à la coordonnée verticale
C pas sorcier non ?
Petite remarque : si vous comptez Afficher plus de 100 caractères agrandissez
la taille du tableau IMGS
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
Key:=Upcase(key);
if key=#8 then begin
if xpos>=16 then begin
xpos:=xpos-16;
dec(ind);
img[ind].destroy;
end;
end
else if key=#13 then begin
xpos:=0;
ypos:=ypos+16;
Form1.Edit1.text:='';
Key:=#0;
end
else if (ord(key)>92) or (ord(key)<32) then key:=#0
else begin
{*** POUR EVITER UN DEBORDEMENT DU TABLEAU "IMGS" IL FAUT
PLACER ICI UNE LIGNE DU STYLE
If Ind => TAILLE_TABLEAU THEN EXIT;
OU TAILLE_TABLEAU est la taille maximale du tableau IMGS ***}
IMg[ind]:=Timage.create(form1);
Img[ind].Parent:=Form1;
Img[ind].Width:=16;
Img[ind].Height:=16;
Img[ind].left:=xpos;
Img[ind].top:=ypos;
Img[ind].canvas.copyrect(rect(0,0,16,16),Police[ord(key)].canvas,rect(0,0,16,16));
xpos:=xpos+16;
Img[ind].Visible:=True;
inc(Ind);
end;
end;
{*** C'est ici qu'on execute le remplissage de la feuille par la texture "T" ***}
procedure TForm1.FormPaint(Sender: TObject);
begin
Remplir;
end;
{***
J'ai aussi une procédure pour creer un mot sans forcément créer une image par lettre
Variables :
S est la chaine de caractères
MON_IMAGE est le TPIcture réceptacle pour mon mot ou ma phrase
MA_POLICE est mon TBitmap de caractères
HAUTEUR_POLICE est la taille de mes caractères (donc MA_POLICE.Height = HAUTEUR_POLICE et MA_POLICE.Width = HAUTEUR_POLICE * 61)
CANVAS_VIDE est un TBitmap de HAUTEUR_POLICE * HAUTEUR_POLICE contenant la couleur du fond (une sorte d'espace quoi) pour
eviter d'afficher un carré noir
Sans_Accent est une procédure qui me vire les accents d'une phrase
é = e
è = e
ê = e
ù = u
...
et je met bien entendu ma chaine en majuscule
Procedure Creer_Canvas(S : String);
Var
N,
I : Integer;
T : String;
Begin
With MON_IMAGE Do
Begin
Height := HAUTEUR_POLICE;
For N := 0 To Width Do
If (N mod HAUTEUR_POLICE) = 0
Then Canvas.CopyRect(Rect(N-HAUTEUR_POLICE,HAUTEUR_POLICE+1,N,-1),
CANVAS_VIDE.Bitmap.Canvas,
Rect(1,HAUTEUR_POLICE+1,HAUTEUR_POLICE,0));
S := UpperCase(Sans_Accent(S));
For N := 1 To Length(S) Do Begin
I := Ord(UpCase(S[N]))-32;
If (I <= 61)
Then Begin
Canvas.CopyRect(rect(HAUTEUR_POLICE*(N-1),HAUTEUR_POLICE,HAUTEUR_POLICE*N,0),
MA_POLICE.Canvas,
Rect(I*HAUTEUR_POLICE,HAUTEUR_POLICE,(I+1)*HAUTEUR_POLICE,0));
T := T + S[N];
End
Else Begin
Canvas.CopyRect(rect(HAUTEUR_POLICE*(N-1),HAUTEUR_POLICE,HAUTEUR_POLICE*N,0),
CANVAS_VIDE.Bitmap.Canvas,
Rect(1,HAUTEUR_POLICE+1,HAUTEUR_POLICE,0));
T := T + #32;
End
End;
End;
End;
End.
Conclusion :
Cette routine n'a pas d'autres prétentions que de servir d'exemple.
Si quelqu'un la trouve utile, tant mieux !!
Libre à vous de modifier, triturer, malmener le code.
Envoyez moi juste une petite bafouille que je sache où peut bien finir mon code.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.