Hola GerTorresM.
Código Delphi
[-]
procedure SaveFieldFont(aDataSet: TDataSet; aFont: TFont;
const BlobFieldName: string);
var
ms: TStream;
LogFont: TLogFont;
sColor: TColor;
begin
ZeroMemory(@LogFont, SizeOf(LogFont));
GetObject(aFont.Handle, SizeOf(LogFont), @LogFont);
sColor := aFont.Color;
ms := TMemoryStream.Create;
try
ms.WriteBuffer(LogFont, SizeOf(LogFont));
ms.WriteBuffer(sColor, SizeOf(TColor));
with aDataSet do
begin
if not (State in [dsEdit,dsInsert]) then Edit;
TBlobField(FieldByName(BlobFieldName)).LoadFromStream(ms);
end;
finally
ms.Free;
end;
end;
procedure LoadFieldFont(aDataSet: TDataSet; aFont: TFont;
const BlobFieldName: string);
var
ms: TStream;
LogFont: TLogFont;
sColor: TColor;
begin
ms := TMemoryStream.Create;
try
TBlobField(aDataSet.FieldByName(BlobFieldName)).SaveToStream(ms);
ms.Seek(soFromBeginning, 0);
ZeroMemory(@LogFont, SizeOf(LogFont));
ms.ReadBuffer(LogFont, SizeOf(LogFont));
ms.ReadBuffer(sColor, SizeOf(TColor));
aFont.Color := sColor;
aFont.Handle := CreateFontIndirect(LogFont);
aFont.Height := LogFont.lfHeight;
if Boolean(LogFont.lfItalic) then
aFont.Style := aFont.Style + [fsItalic];
if Boolean(LogFont.lfUnderline) then
aFont.Style := aFont.Style + [fsUnderline];
if Boolean(LogFont.lfStrikeOut) then
aFont.Style := aFont.Style + [fsStrikeOut];
if Boolean(LogFont.lfWeight and 700) then
aFont.Style := aFont.Style + [fsBold];
finally
ms.Free;
end;
end;
Ejemplo de uso:
Código Delphi
[-]
procedure TForm1.FormCreate(Sender: TObject);
begin
Table1.Open;
Label1.Font.Name := 'Segoe Print';
Label1.Font.Size := 18;
Label1.Font.Color := clRed;
Label1.Font.Style := [fsItalic, fsStrikeOut, fsBold];
Label1.Caption := 'Caption Label1';
end;
procedure TForm1.btSaveClick(Sender: TObject);
begin
Table1.Edit;
Table1.FieldByName('Texto').AsString := Label1.Caption;
SaveFieldFont(Table1, Label1.Font, 'Fuente');
Table1.Post;
end;
procedure TForm1.btLoadClick(Sender: TObject);
begin
Label2.Caption := Table1.FieldByName('Texto').AsString;
LoadFieldFont(Table1, Label2.Font, 'Fuente');
end;
Saludos