[[Lepe]]

hace unas semanas me hizo falta eso mismo, pero guardando en la base de datos la fuente que se ha de usar, encontré un ejemplo en internet y lo adapté a mis necesidades:

Código Delphi [-]
unit LpFont;

interface

uses Graphics,sysutils, types,windows;
const SALTOLINEA = #10#13;
type TInclude= (iName,iSize,iStyle);
type TSetOfInclude = set of TInclude;
const descripcion:array [TInclude] of string =('Fuente: ',
                                               'Tamaño: ',
                                               'Estilo: ');

{-----------------------------------------------------------------------------
  Procedure: FontToStr
  Author:    Lepe
  Date:      08-feb-2005
  Arguments: Font: TFont
  Result:    string

  Devuelve una cadena de estilo:Times New Roman,0,16711680,16,7
  que sigue el patron:
  Nombre, charset, color, tamaño, Negrita + cursiva + subrayado
-----------------------------------------------------------------------------}
function FontToStr(Font: TFont):string;

{-----------------------------------------------------------------------------
  Procedure: StrToFont
  Author:    Lupas
  Date:      08-feb-2005
  Arguments: str: string; FontToModify: TFont
  Result:    None

  Dada una fuente en formato:Times New Roman,0,16711680,16,7
  aplica los valores al parametro FontToModify
-----------------------------------------------------------------------------}
procedure StrToFont(str: string; FontToModify: TFont);

{-----------------------------------------------------------------------------
  Procedure: StrFontToText
  Author:    Lepe
  Date:      08-feb-2005
  Arguments: str: string;
             const UseBreakLine:Boolean = True;
             const Options:TSetOfInclude=[iName,iSize,iStyle]
  Result:    string

  Dada un string: Times New Roman,0,16711680,16,7
  devuelve un String más descriptivo:
   Fuente: MS Sans Serif; Tamaño: 24; Estilo:  Negrita  Cursiva  Subrayado

   Si UsebreakLine:
    Fuente: MS Sans Serif;
    Tamaño: 24;
    Estilo:  Negrita  Cursiva  Subrayado

   El texto 'Fuente' 'Tamaño' 'Estilo' salen siempre
-----------------------------------------------------------------------------}
function StrFontToText(str: string;const UseBreakLine:Boolean = True;
                  const Options:TSetOfInclude=[iName,iSize,iStyle]):string;


function FontWidthInPixels(SurfaceToPaint:THandle; Str:string;var TheWidth:integer):Boolean;
function FontHeigthInPixels(SurfaceToPaint:THandle; Str:string; var TheHeight : integer):boolean;
function FontDimensionInPixels(SurfaceToPaint:THandle; Str:string;var TheSize : Tsize):Boolean;

implementation

function FontDimensionInPixels(SurfaceToPaint:THandle; Str:string;var TheSize : Tsize):Boolean;
begin
  Result := windows.GetTextExtentPoint32(SurfaceToPaint,PChar(str),Length(Str),TheSize)
end;


function FontHeigthInPixels(SurfaceToPaint:THandle; Str:string; var TheHeight : integer):Boolean;
var s:TSize;
begin
  Result := FontDimensionInPixels(SurfaceToPaint,Str,S);
  if Result then TheHeight := s.cy;
end;

function FontWidthInPixels(SurfaceToPaint:THandle; Str:string;var TheWidth:integer):Boolean;
var s:TSize;
begin
  Result := fontdimensioninPixels(SurfaceToPaint,Str,S);
  if Result then TheWidth:= s.cx;
end;

function FontToStr(Font: TFont):string;
begin
  if Assigned(Font) then
    Result:= Font.Name + ',' +
             IntToStr(Font.CharSet) + ',' +
             IntToStr(Font.Color) + ',' +
             IntToStr(Font.Size) + ',' +
             IntToStr(Byte(Font.Style))
  else
    Result := ',,,,';
end;

procedure StrToFont(str: string; FontToModify: TFont);
var s, Data: string;
    i: Integer;
begin
  if not Assigned(FontToModify) then
    raise Exception.Create('se necesita una fuente creada.');
  s := str;
  try
    i := Pos(',', s);
    if i > 0 then
    begin
      {Name}
      Data := Trim(Copy(s, 1, i-1));
      if Data <> '' then
        FontToModify.Name := Data;
      Delete(s, 1, i);
      i := Pos(',', s);
      if i > 0 then
      begin
        {CharSet}
        Data := Trim(Copy(s, 1, i-1));
        if Data <> '' then
          FontToModify.Charset := TFontCharSet(StrToIntDef(Data, FontToModify.Charset));
        Delete(s, 1, i);
        i := Pos(',', s);
        if i > 0 then
        begin
          {Color}
          Data := Trim(Copy(s, 1, i-1));
          if Data <> '' then
            FontToModify.Color := TColor(StrToIntDef(Data, FontToModify.Color));
          Delete(s, 1, i);
          i := Pos(',', s);
          if i > 0 then
          begin
           {Size}
           Data := Trim(Copy(s, 1, i-1));
           if Data <> '' then
             FontToModify.Size := StrToIntDef(Data, FontToModify.Size);
           Delete(s, 1, i);
           {Style}
           Data := Trim(s);
           if Data <> '' then
             FontToModify.Style := TFontStyles(Byte(StrToIntDef(Data, Byte(FontToModify.Style))));
          end
        end
      end
    end;
  except
  end;
end;

function StrFontToText(str: string;const UseBreakLine:Boolean = True;
const Options:TSetOfInclude=[iName,iSize,iStyle]):string;
var s, Data: string;
    i: Integer;
    Style:TFontStyles;
begin
  s := str;
  try
    i := Pos(',', s);
    if i > 0 then
    begin
      {Name}
      Data := Trim(Copy(s, 1, i-1));
      if Data <> '' then
        if iname in Options then
        Result := Result + descripcion[iname]+Data+';';
        if UseBreakLine then
          Result := Result + SALTOLINEA;
      Delete(s, 1, i);
      i := Pos(',', s);
      if i > 0 then
      begin
        {CharSet}
        Data := Trim(Copy(s, 1, i-1));
        Delete(s, 1, i);
        i := Pos(',', s);
        if i > 0 then
        begin
          {Color}
          Data := Trim(Copy(s, 1, i-1));
          Delete(s, 1, i);
          i := Pos(',', s);
          if i > 0 then
          begin
           {Size}
           Data := Trim(Copy(s, 1, i-1));
           if Data <> '' then
             if isize in Options then
               Result := Result + descripcion [isize ]+Data+';' ;
           if UseBreakLine then
             Result := Result + SALTOLINEA;
           Delete(s, 1, i);
           {Style}
           Data := Trim(s);
           if Data <> '' then
           begin
             Style := TFontStyles(Byte(StrToIntDef(Data,0)));
             if StrToIntDef(Data,0) <> 0 then
              if istyle in Options then
              begin
                 Result := Result + descripcion[istyle];
                 if fsbold in Style then
                  Result := Result+ ' Negrita ';
                 if fsitalic in Style then
                  Result := Result + ' Cursiva ';
                 if fsunderline in Style then
                  Result := Result + ' Subrayado ';
                 if UseBreakLine then
                   Result := Result + SALTOLINEA;
              end;
           end;
          end
        end
      end;
      // quitamos el ultimo salto de linea;
      if UseBreakLine then
        Delete(Result,Length(Result)-Length(SALTOLINEA),Length(SALTOLINEA));
    end;
  except
  end;
end;
end.