How to programmatically alter Font properties in Firemonkey controls

StackOverflow https://stackoverflow.com/questions/13884089

Question

I have some code that paints a set of controls laid on top of a TImage. I then grab the TImage's MakeScreenshot to save out the file. This now works perfectly. What I am now struggling with is changing the font properties of one or more labels / text style controls. No matter what I try, the label does not change. Below is my sample code :-

procedure TfrmSnapshot.Process;
var
  LRect1, LRect2, LRect3, LRect4: TRectF;
  X, Y, W, H: Integer;

begin
//
X := Round(Label1.Position.X);
Y := Round(Label1.Position.Y);
W := Round(X + Label1.Width);
H := Round(Y + Label1.Height);
LRect1.Create(X, Y, W, H);

X := Round(Label2.Position.X);
Y := Round(Label2.Position.Y);
W := Round(X + Label2.Width);
H := Round(Y + Label2.Height);
LRect2.Create(X, Y, W, H);

X := Round(Label3.Position.X);
Y := Round(Label3.Position.Y);
W := Round(X + Label3.Width);
H := Round(Y + Label3.Height);
LRect3.Create(X, Y, W, H);

X := Round(Rect1.Position.X);
Y := Round(Rect1.Position.Y);
W := Round(X + Rect1.Width);
H := Round(Y + Rect1.Height);
LRect4.Create(X, Y, W, H);

Label1.Text := fTitle;
Label1.Font.Size := 40.0;
Label2.Text := fSub;
Label3.Text := fSite;

With imgSnap.Bitmap Do
Begin
  Label1.Font.Size = 40; //Does not work
  Label1.Font.Family = 'Arial'; //Does not work
  Label1.PaintTo(Canvas, LRect1);
  Label2.PaintTo(Canvas, LRect2);
  Label3.PaintTo(Canvas, LRect3);
  Rect1.PaintTo(Canvas, LRect4);
End;

imgSnap.MakeScreenshot.SaveToFile('test.jpg');
end;

How do I set the fonts of the labels so that they are painted properly and thus included in the screenshot ?

Regards Anthoni

Was it helpful?

Solution 2

OK, so here is what is working for me.
What I needed to do was wrap what ever I wanted to display in the image inside a TRectangle and then paint the Rectangle onto the image. I also had to change the default properties of the control inside the Rectangle, for example I had to change the font name and font size. Then I could alter them to what ever I wanted after that. Also need to make sure the form displaying the image want to snapshot is visible (form.show)

This works for me and is in Public use and I have had no faults with it.

Pascal Source Code:

unit FormSnap;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.UIConsts, System.Rtti, System.Classes,
  System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Objects, FMX.Layouts, AVConverter;

type
  TfrmSnapshot = class(TForm)
    lblMainTitle: TLabel;
    lblSubTitle: TLabel;
    lblWebsite: TLabel;
    imgSnap: TImage;
    RectMainTitle: TRectangle;
    RectSubTitle: TRectangle;
    RectWebsite: TRectangle;
    AVConvert: TAVConverter;

    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
    procedure FormDestroy(Sender: TObject);
    procedure AVConvertComplete(Sender: TObject);

  private
    fBitmap: TBitmap;
    fSub: String;
    fTitle: String;
    fSite: String;
    fShown, fProcessingVideo: Boolean;
    fSaveTo, fSaveVideoTo: String;
    fColorBack: Cardinal;
    fColorSub: Cardinal;
    fColorTitle: Cardinal;
    fColorSite: Cardinal;
    fOnReady, fOnFinished: TNotifyEvent;

    Procedure zp_CreateImage;
    Function zp_GetLRect(Const AControl: TControl): TRectF;
  public
    Property ColorBack: Cardinal read fColorBack write fColorBack;
    Property ColorTitle: Cardinal read fColorTitle write fColorTitle;
    Property ColorSub: Cardinal read fColorSub write fColorSub;
    Property ColorWebsite: Cardinal read fColorSite write fColorSite;
    Property SaveTo: String read fSaveTo write fSaveTo;
    Property SaveVideoTo: String read fSaveVideoTo write fSaveVideoTo;
    Property SlideTitle: String read fTitle write fTitle;
    Property SlideSubTitle: String read fSub write fSub;
    Property SlideWebsite: String read fSite write fSite;

    Procedure Process;
    Procedure ProcessVideo;
    Property OnFinished: TNotifyEvent read fOnFinished write fOnFinished;
    Property OnReady: TNotifyEvent read fOnReady write fOnReady;
  end;

var
  frmSnapshot: TfrmSnapshot;

implementation
Uses uShared.Project, AVCodec, AVLib;

{$R *.fmx}
procedure TfrmSnapshot.AVConvertComplete(Sender: TObject);
begin
  //
  if Pos('temp', Lowercase(fSaveTo)) <> 0 then
    DeleteFile(fSaveTo);

  if Assigned(fOnFinished) then
    fOnFinished(Self);
end;

procedure TfrmSnapshot.FormCreate(Sender: TObject);
begin
  //
  imgSnap.Bitmap := TBitmap.Create(Round(imgSnap.Width), Round(imgSnap.Height));
  fColorBack := claYellow;
  fColorSub := claBlack;
  fColorTitle := claBlack;
  fColorSite := claBlue;
  fTitle := 'Simple slide';
  fSub := 'Another slide';
  fSite := '';

  fBitmap := TBitmap.Create(0, 0);
  Height := 360;
  Width := 640;
end;

procedure TfrmSnapshot.FormDestroy(Sender: TObject);
begin
  //
  fBitmap.Free;
end;

procedure TfrmSnapshot.FormPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
begin
  //
  if (Assigned(fOnReady)) AND (NOT fShown) then
  Begin
    fOnReady(Self);
    fShown := True;
  End;
end;

procedure TfrmSnapshot.Process;
begin
  //
  fProcessingVideo := False;
  zp_CreateImage;
  if Assigned(fOnFinished) then
    fOnFinished(Self);
end;

procedure TfrmSnapshot.ProcessVideo;
begin
  //
  fProcessingVideo := True;
  fSaveTo := Project.FolderTemp + 'snap.jpg';

  With AVConvert Do
  Begin
    if State <> csRunning then
    Begin
      zp_CreateImage;
      fBitmap.LoadFromFile(fSaveTo);

      ConvertOptions.InputFormats.Text:='bmpcap';
      InputFiles.Add(IntToStr(Integer(fBitmap)));
      OutputFiles.Text:= fSaveVideoTo;
      ConvertOptions.RecordingTime:=30*AV_TIME_BASE;
      Convert();
    End;
  End;
end;

procedure TfrmSnapshot.zp_CreateImage;
begin
  //
  RectMainTitle.Fill.Color := fColorBack;
  RectSubTitle.Fill.Color := fColorBack;
  RectWebsite.Fill.Color := fColorBack;

  With lblMainTitle Do
  Begin
    FontColor := fColorTitle;
    Text := fTitle;
  End;

  With lblSubTitle Do
  Begin
    FontColor := fColorSub;
    Text := fSub;
  End;

  With lblWebsite Do
  Begin
    FontColor := fColorSite;
    Text := fSite;
  End;

  With imgSnap.Bitmap Do
  Begin
    Clear(fColorBack);
    RectMainTitle.PaintTo(Canvas, zp_GetLRect(RectMainTitle));
    RectSubTitle.PaintTo(Canvas, zp_GetLRect(RectSubTitle));
    RectWebsite.PaintTo(Canvas, zp_GetLRect(RectWebsite));
  End;

  imgSnap.MakeScreenshot.SaveToFile(fSaveTo);
end;

function TfrmSnapshot.zp_GetLRect(const AControl: TControl): TRectF;
var
  X, Y, W, H: Single;

begin
  //
  X := AControl.Position.X;
  Y := AControl.Position.Y;
  W := X + AControl.Width;
  H := Y + AControl.Height;
  Result := TRectF.Create(X, Y, W, H);
end;

end.

Form Source Code:

object frmSnapshot: TfrmSnapshot
  Left = 0
  Top = 0
  BorderStyle = bsNone
  ClientHeight = 360
  ClientWidth = 640
  Position = poScreenCenter
  FormFactor.Width = 1920
  FormFactor.Height = 1080
  FormFactor.Devices = [dkDesktop]
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnPaint = FormPaint
  object imgSnap: TImage
    Align = alClient
    Height = 360.000000000000000000
    Width = 640.000000000000000000
  end
  object RectMainTitle: TRectangle
    Height = 90.000000000000000000
    Position.X = 8.000000000000000000
    Position.Y = 60.000000000000000000
    Stroke.Kind = bkNone
    Width = 625.000000000000000000
    object lblMainTitle: TLabel
      Align = alClient
      Font.Family = 'Impact'
      Font.Size = 40.000000000000000000
      FontColor = claAliceblue
      StyledSettings = []
      Height = 90.000000000000000000
      Text = 'I am just some silly information. Testing Wordwrap'
      TextAlign = taCenter
      Width = 625.000000000000000000
    end
  end
  object RectSubTitle: TRectangle
    Height = 90.000000000000000000
    Position.X = 8.000000000000000000
    Position.Y = 200.000000000000000000
    Stroke.Kind = bkNone
    Width = 625.000000000000000000
    object lblSubTitle: TLabel
      Align = alClient
      Font.Family = 'Impact'
      Font.Size = 20.000000000000000000
      FontColor = claAliceblue
      StyledSettings = []
      Height = 90.000000000000000000
      Text = 'More Information'
      TextAlign = taCenter
      Width = 625.000000000000000000
    end
  end
  object RectWebsite: TRectangle
    Height = 17.000000000000000000
    Position.Y = 340.000000000000000000
    Stroke.Kind = bkNone
    Width = 640.000000000000000000
    object lblWebsite: TLabel
      Align = alClient
      Font.Family = 'Impact'
      FontColor = claAliceblue
      StyledSettings = [ssSize]
      Height = 17.000000000000000000
      Text = 'Just a website'
      TextAlign = taCenter
      Width = 640.000000000000000000
    end
  end
  object AVConvert: TAVConverter
    ConvertOptions.LimitFileSize = 9223372036854775807
    ConvertOptions.AudioOptions.AudioChannels = 0
    ConvertOptions.AudioOptions.AudioSampleRate = 0
    ConvertOptions.AudioOptions.AudioVolume = 256
    ConvertOptions.AudioOptions.AudioSyncMethod = 0
    ConvertOptions.AudioOptions.AudioDisable = False
    ConvertOptions.AudioOptions.AudioSampleFmt = sfAuto
    ConvertOptions.AudioOptions.AudioStreamCopy = False
    ConvertOptions.AudioOptions.AudioCodecTag = 0
    ConvertOptions.AudioOptions.AudioQScale = -99999.000000000000000000
    ConvertOptions.AudioOptions.AudioDriftThreshold = 0.100000001490116100
    ConvertOptions.AudioOptions.Bitrate = 0
    ConvertOptions.AudioOptions.MaxFrames = 9223372036854775807
    ConvertOptions.SubtitleOptions.SubtitleDisable = False
    ConvertOptions.SubtitleOptions.SubtitleCodecTag = 0
    ConvertOptions.VideoOptions.FrameWidth = 0
    ConvertOptions.VideoOptions.FrameHeight = 0
    ConvertOptions.VideoOptions.VideoDisable = False
    ConvertOptions.VideoOptions.VideoStreamCopy = False
    ConvertOptions.VideoOptions.VideoCodecTag = 0
    ConvertOptions.VideoOptions.IntraOnly = False
    ConvertOptions.VideoOptions.TopFieldFirst = -1
    ConvertOptions.VideoOptions.ForceFPS = False
    ConvertOptions.VideoOptions.FrameRate.num = 0
    ConvertOptions.VideoOptions.FrameRate.den = 0
    ConvertOptions.VideoOptions.MeThreshold = 0
    ConvertOptions.VideoOptions.Deinterlace = False
    ConvertOptions.VideoOptions.Pass = 0
    ConvertOptions.VideoOptions.MaxFrames = 2147483647
    ConvertOptions.VideoOptions.Bitrate = 0
    ConvertOptions.MuxerOptions.MuxPreload = 0.500000000000000000
    ConvertOptions.StartTime = 0
    ConvertOptions.RecordingTime = 9223372036854775807
    OnComplete = AVConvertComplete
    Left = 304
    Top = 200
  end
end

Hope this helps someone else who is having this problem.

Regards Anthoni

PS: Sorry forgot to add, please ignore the AVConvertor component, that is there to allow me to create an actual video of the component (mp4) so that I can merge it with another.

OTHER TIPS

In firemonkey TLabel properties Font.Family and Font.Size are styled. If you want change font size or family in the code, you need to disable styling on this properties. To change this, set properly property StyledSettings.

example:

Label1.StyledSettings:=Label1.StyledSettings -[TStyledSetting.ssFamily,TStyledSetting.ssSize]
Licensed under: CC-BY-SA with attribution
Not affiliated with StackOverflow
scroll top