[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