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
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]
Anthoni Gardner
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.
来源：https://stackoverflow.com/questions/13884089/how-to-programmatically-alter-font-properties-in-firemonkey-controls