I have form (Height = 500) and TVertScrollBox on it (align set to TAlignLayout.Client and range is 5000px). I wrote simple method, which show position of mouse when I click on scroll box.
procedure TformMain.VertScrollBox1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
ShowMessage(FloatToStr(X) + ' ' + FloatToStr(Y));
end;
When the scroll bar is on top and I click on top of the scroll box, Y in message is 0. That's right. But when I scroll down to the half and click on top of the scroll box, Y in message is 0, too (not 2500). How can I get the position relative to scroll box?
This is my FMX code for TForm and TVertScrollBox:
object formMain: TformMain
Left = 0
Top = 0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = Single
Caption = 'Gear Studio 1.0'
ClientHeight = 600
ClientWidth = 450
Position = DesktopCenter
StyleBook = StyleBookPanel
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
OnCloseQuery = FormCloseQuery
DesignerMasterStyle = 0
object VertScrollBox1: TVertScrollBox
Align = Client
Size.Width = 450.000000000000000000
Size.Height = 576.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'VertScrollBox1Style1'
TabOrder = 1
OnMouseDown = VertScrollBox1MouseDown
Viewport.Width = 450.000000000000000000
Viewport.Height = 576.000000000000000000
end
...
...
end
That's how I am adding panels:
SetLength(MyItems, i+1);
MyItems[i] := TItem.Create(i);
with MyItems[i] do begin
...
end;
constructor TItem.Create(number: integer);
var
ThisItem: TItem;
begin
inherited Create(nil);
ThisItem := Self;
with ThisItem do begin
if number = -1 then begin
... //not important
end;
end else if number > 0 then begin
Width := 370;
Height := 35;
...
end;
Position.X := 10;
Parent := formMain.VertScrollBox1;
PopupMenu := formMain.PopupMenu1;
OnDblClick := DblClick;
OnMouseEnter := MouseEnter;
OnMouseLeave := MouseLeave;
end;
end;
MyItems is dynamical array of TItem (it is normal TPanel with added some properties).
You need to add VertScrollBox1.ViewportPosition.Y property to get the absolute coordinate.
ShowMessage(FloatToStr(X) + ' ' + FloatToStr(VertScrollBox1.ViewportPosition.Y+Y));
shows correct result.
Related
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]
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.
I have a form with at TListBox that I populate in the onCreate event, where I also set the selected item. I want the List Box to have the selected item in view when the form shows, so I tried firing the ScrollToItem method. This does not work. I also tried putting it in OnShow and OnActivate events, but it still does not work. Is there a way to get this to work?
Here is a sample program that illustrates the problem:
`type
TForm5 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.fmx}
procedure TForm5.FormCreate(Sender: TObject);
var
i: Integer;
lbi: TListBoxItem;
begin
for i := 1 to 50 do
begin
lbi := TListBoxItem.Create(ListBox1);
lbi.Text := 'item ' + inttostr(i);
ListBox1.AddObject( lbi );
end;
ListBox1.itemindex := ListBox1.items.indexof('item 48');
ListBox1.ScrollToItem(ListBox1.Selected);
end;
end.`
and the FMX file:
`object Form5: TForm5
Left = 0
Top = 0
Caption = 'Form5'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object ListBox1: TListBox
Position.X = 224.000000000000000000
Position.Y = 144.000000000000000000
TabOrder = 1
DisableFocusEffect = True
DefaultItemStyles.ItemStyle = ''
DefaultItemStyles.GroupHeaderStyle = ''
DefaultItemStyles.GroupFooterStyle = ''
Viewport.Width = 196.000000000000000000
Viewport.Height = 196.000000000000000000
end
end`
TListBox has a property ViewportPosition: TPointF that sets the scrollbars. Add the following line after you set ListBox1.ItemIndex:
ListBox1.ViewportPosition := PointF(0.0, ListBox1.itemindex * ListBox1.ItemHeight);
The previous assumes that all items have the same height (TListBox1.ItemHeight set in Object Inspector or in code earlier). Your FMX file doesn't reflect this, so you may want to add it, otherwise the scrolling will not take place.
You might want to set individual height for the items. In that case you must traverse all items up to the one you want to be selected and sum their heights to get the Y term for the ViewportPosition.
I have several task on button click.
eg.
Show form or please wait panel....
Load data from database (duration 5-10 seconds)
Clear all TEdit field
Hide form or please wait panel....
ShowMessage('completed')
Is it possible After click on button show please wait panel or form and after all completed hide that panel.
How to Synchronize Perform Tasks One by one.
Or any other simple solution.
This is a simple example that creates a "placeholder" which looks like this:
The rectangle has a black background and contains a layout which is aligned to Center; inside you can find a label (aligned to Top) and an arc (aligned to Client). The code is here:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 418
ClientWidth = 490
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object Rectangle1: TRectangle
Align = Client
Fill.Color = xFF222222
Size.Width = 490.000000000000000000
Size.Height = 418.000000000000000000
Size.PlatformDefault = False
Visible = False
object Layout1: TLayout
Align = Center
Size.Width = 170.000000000000000000
Size.Height = 102.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
object Label1: TLabel
Align = Top
StyledSettings = [Family, Size, Style]
Size.Width = 170.000000000000000000
Size.Height = 41.000000000000000000
Size.PlatformDefault = False
TextSettings.FontColor = claWhite
TextSettings.HorzAlign = Center
Text = 'Please wait'
TabOrder = 0
end
object Arc1: TArc
Align = Center
Size.Width = 50.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
Stroke.Color = claCoral
EndAngle = -90.000000000000000000
object FloatAnimation1: TFloatAnimation
Enabled = True
Duration = 1.000000000000000000
Loop = True
PropertyName = 'RotationAngle'
StartValue = 0.000000000000000000
StopValue = 360.000000000000000000
end
end
end
end
end
The Visible property of the rectangle is set to False so that you won't see immediately the rectangle. Note that I have created an animation in the arc component so that you can see it spinning around:
In this way you can mimic a loading spinner. Then I have added this code in the OnCreate event of the form just as example of how you could do this.
procedure TForm1.FormCreate(Sender: TObject);
begin
TTask.Run(procedure
begin
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := true;
//Rectangle1.BringToFront;
// ^ call the above if needed, just to be sure
// that you'll always see the rectangle on screen
end);
Sleep(4000);
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := false;
ShowMessage('Finish!');
end);
end);
end;
The Sleep(4000) simulates a long task and this piece of code should be replaced with your tasks. Actually I'd do something like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
TTask.Run(procedure
var
arr: array [0..1] of ITask;
begin
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := true;
Rectangle1.BringToFront;
end);
arr[0] := TTask.Run(procedure
begin
//load data from the database
end);
arr[1] := TTask.Run(procedure
begin
//something else
end);
//this call is blocking but you are calling this in a worker thread!
//your UI won't freeze and at the end you'll see the message appearing
TTask.WaitForAll(arr);
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := false;
ShowMessage('Finish!');
end);
end);
end;
Of course you should place this code in a ButtonClick and not in a FormCreate event handler!
what i try to do is same as this image
thing i have tried panel1.top := ListView1.Items[i].position.Y;
but it didnt success with this trick , is there possibly way to aligned Tpanel at a bottom of some items
Actual code added
procedure Ttestthreading.streamClick(Sender: TObject);
var
i, R: integer;
begin
if stream.Caption = 'stream' then
begin
for i := 0 to ListView1.Items.Count - 1 do
if ListView1.Items[i].SubItems[3] = IntToStr(UniqueID) then
begin
R := ListView1.Items[i].Index;
panel2.Top := ListView1.Items[i].Position.Y;
end;
ExchangeItems(ListView1, R, 0);
stream.Caption := 'stopstream';
panel2.Visible := true;
// start stream
end
else if stream.Caption = 'stopstream' then
begin
ExchangeItems(ListView1, R, 0);
stream.Caption := 'stream';
panel2.Visible := false;
// stopstream
end;
end;
If you check the documentation http://docwiki.embarcadero.com/Libraries/XE2/en/Vcl.ComCtrls.TListItem.Position you will see that TListitem.Position only works when ListView view style is either vsIcon or vsSmallIcon.
So instead of using Position property you should rather use DisplayRect method http://docwiki.embarcadero.com/Libraries/XE2/en/Vcl.ComCtrls.TListItem.DisplayRect which returns the rectangle in which the List item is rendered.
Take a new form, copy this code and paste it onto the form
object ListView1: TListView
Left = 0
Top = 40
Width = 250
Height = 296
Anchors = [akLeft, akTop, akRight, akBottom]
Columns = <>
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Top = 0
Width = 250
Height = 41
Anchors = [akLeft, akTop, akRight]
Caption = 'Panel1'
TabOrder = 1
end
First I arrange the two objects at designtime. Then I set anchors on both objects.
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]
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.