[Lazarus-es] Graficos: ttf que no está en el Sistema
Juan M. Puertas
soft.sirius en gmail.com
Jue Feb 12 10:51:00 CET 2015
Hola. He estado haciendo pruebas en un pequeño programa para manejar
fuentes y canvas en un TBitmap y luego pasar la imagen a un TImage. Pongo
aquí el código por si a alguien le hiciera falta alguna vez:
________________________________________________________
...
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls,
LCLIntf, LCLType,
fpimage,
IntfGraphics, GraphType, //Intf basic routines
EasyLazFreeType, LazFreeTypeIntfDrawer //EasyFreeType with Intf
;
type
{ TForm1 }
TForm1 = class(TForm)
BtnHaz: TButton;
Bmp: TImage;
procedure BtnHazClick(Sender: TObject);
...
procedure TForm1.BtnHazClick(Sender: TObject);
var
bmp2: TBitmap;
lazimg: TLazIntfImage;
drawer: TIntfFreeTypeDrawer;
ftFont1: TFreeTypeFont;
begin
SetBkMode(Form1.bmp.Canvas.Handle, TRANSPARENT);
Form1.bmp.Canvas.FillRect(0,0, Form1.bmp.width,Form1.bmp.height);
Form1.bmp.Canvas.Brush.Color:=RGBToColor(255,255,255);
bmp2 := TBitmap.Create;
lazimg := TLazIntfImage.Create(0,0, [riqfRGB]);
drawer := TIntfFreeTypeDrawer.Create(lazimg);
ftFont1 := nil;
ftFont1 := TFreeTypeFont.Create;
ftFont1.Name := 'AstroGadget.ttf';
ftFont1.SizeInPoints := 27;
lazimg.SetSize(Form1.bmp.Width,Form1.bmp.Height);
drawer.FillPixels(TColorToFPColor(clWhite));
ftFont1.Hinted := true;
ftFont1.ClearType := true;
ftFont1.Quality := grqHighQuality;
ftFont1.SmallLinePadding := false;
SetBkMode(bmp2.Canvas.Handle, TRANSPARENT);
drawer.DrawTextRect('ABCDEFGHIJKLMNOPQRSTUVWXYZ', ftFont1, 0,0, 350,90,
colBlack, [ftaLeft, ftaBottom]);
bmp2.LoadFromIntfImage(lazimg);
bmp2.Canvas.Brush.Style := bsClear;
bmp2.Canvas.Ellipse(10,10,90,90);
Form1.bmp.Canvas.Draw(0, 0, bmp2);// Copia bmp2 a bmp
bmp2.Free;
________________________________________________________
Gracias :-)
El 11 de febrero de 2015, 23:24, Juan M. Puertas <soft.sirius en gmail.com>
escribió:
> Muchas gracias José. Elijo la solución "sencilla" :-)
> He estado investigando , y voy a tener que reconvertir tres objetos Timage
> con sus numerosos Canvas, etc., a TBitmap. Seguro que se me ocurre algún
> truco para que no sea engorroso.
> Gracias también a ti, Iván por el intento. ;-)
>
> El 11 de febrero de 2015, 15:26, José Mejuto <joshyfun en gmail.com>
> escribió:
>
> El 11/02/2015 a las 12:34, Juan M. Puertas escribió:
>>
>>> Hola.
>>> He hecho una aplicación que dibuja en un TImage una serie de canvas con
>>> elipses, líneas, etc. y quisiera añadir unos símbolos de una fuente ttf
>>> que no está en el Sistema.
>>>
>>
>> Hola,
>>
>> Tienes dos opciones, la "sencilla" es usar la unit freetype o LazFreeType
>> http://wiki.lazarus.freepascal.org/LazFreeType
>>
>> La "complicada" es que para usar una font en Windows has de registrarla
>> en el sistema, lo que es básicamente lo mismo que instalar la fuente, pero
>> puedes hacerlo de modo temporal, esto es, que el registro sólo es válido
>> mientras tu programa esté en ejecución y se desregistra al salir. Además no
>> necesita que la fuente esté en Windows\fonts si no que puede estar donde tu
>> quieras.
>>
>> El primer modo es multiplataforma, el segundo sólo Windows.
>>
>> Sólo para Windows sería algo como esto, en versión simplificada.
>>
>> procedure TForm1.FormCreate(Sender: TObject) ;
>> begin
>> AddFontResource('c:\FONTS\MyFont.TTF') ;
>> SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
>> end;
>>
>> // Al cerrar el form principal!
>> procedure TForm1.FormDestroy(Sender: TObject) ;
>> begin
>> RemoveFontResource('C:\FONTS\MyFont.TTF') ;
>> SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
>> end;
>>
>> Aunque yo lo haría en el lpr, no en el form, para que la fuente esté
>> disponible para todos los forms, y lo protegería con un try...finally.
>>
>> --
>>
>>
>> _______________________________________________
>> Lazarus-es mailing list
>> Lazarus-es en lists.lazarus.freepascal.org
>> http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus-es
>>
>
>
>
> --
> *Nota: Por problemas con el e-mail. Puede que recibas de nuevo este
> mensaje en un tiempo.*
>
--
*Nota: Por problemas con el e-mail. Puede que recibas de nuevo este mensaje
en un tiempo.*
------------ próxima parte ------------
Se ha borrado un adjunto en formato HTML...
URL: <http://lists.lazarus-ide.org/pipermail/lazarus-es/attachments/20150212/548b106e/attachment-0002.html>
More information about the Lazarus-es
mailing list