Setup TListview, ItemAppearance = DynamicAppearance
in the OnClickItemEX, let's say there's 2 Textobjects. click on both TextObjects - OK. Click on the space between 2 of them - Access Violation.
if click anywhere not covered by an item will result in an Access Violation for the simplest setup.
If I use OnButtonClick only without using OnClickItemEX, no such AV.
How can I resolve this? see below for a Minimal Working Example. (I'm not sure if it's correct to attach it this way as I don't see an Attachment option to upload a zip file of this mini project).
unit bug_main;
interface
type
TForm1 = class(TForm)
ListView1: TListView;
Button1: TButton;
FDMemTable1: TFDMemTable;
BindSourceDB1: TBindSourceDB;
FDMemTable1CustomerID: TIntegerField;
FDMemTable1CustomerName: TStringField;
BindSourceDB2: TBindSourceDB;
BindingsList1: TBindingsList;
procedure Button1Click(Sender: TObject);
procedure ListView1ItemClickEx(const Sender: TObject; ItemIndex: Integer;
const LocalClickPos: TPointF; const ItemObject: TListItemDrawable);
private
FLinkFillControlToField : TLinkFillControlToField;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
procedure TForm1.Button1Click(Sender: TObject);
begin
with FDMemTable1 do
begin
Open;
Append;
FieldByName('CustomerID').AsInteger := 1;
FieldByName('CustomerName').AsString := 'ABC';
Post;
Append;
FieldByName('CustomerID').AsInteger := 2;
FieldByName('CustomerName').AsString := 'XYZ';
Post;
end;
if not Assigned(FLinkFillControlToField) then
begin
FLinkFillControlToField := TLinkFillControlToField.Create(BindingsList1);
FLinkFillControlToField.Control := listview1;
with FLinkFillControlToField do
begin
Category := 'Quick Bindings';
Track := False;
Direction := linkDataToControl;
AutoActivate := False;
AutoFill := True;
BindSourceDB1.DataSource.Enabled := True;
FillDataSource := BindSourceDB1;
end;
end;
with FLinkFillControlToField do
begin
with FillExpressions.AddExpression do
begin
SourceMemberName := 'CustomerID';
ControlMemberName := 'Text1';
end;
with FillExpressions.AddExpression do
begin
SourceMemberName := 'CustomerName';
ControlMemberName := 'Text2';
end;
end;
FLinkFillControlToField.Active := True;
end;
procedure TForm1.ListView1ItemClickEx(const Sender: TObject; ItemIndex: Integer;
const LocalClickPos: TPointF; const ItemObject: TListItemDrawable);
begin
if itemobject.Name = 'Text1' then
begin
showmessage('clicked on Text1');
end else if itemobject.Name = 'Text2' then
begin
showmessage('clicked on Text2');
end;
end;
end.
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 404
ClientWidth = 763
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object ListView1: TListView
ItemAppearanceClassName = 'TDynamicAppearance'
ItemEditAppearanceClassName = 'TDynamicAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
Position.X = 16.000000000000000000
Position.Y = 24.000000000000000000
Size.Width = 561.000000000000000000
Size.Height = 353.000000000000000000
Size.PlatformDefault = False
ItemAppearanceObjects.ItemObjects.ObjectsCollection = <
item
AppearanceObjectName = 'Text1'
AppearanceClassName = 'TTextObjectAppearance'
Appearance.Width = 223.000000000000000000
Appearance.Height = 44.000000000000000000
end
item
AppearanceObjectName = 'Text2'
AppearanceClassName = 'TTextObjectAppearance'
Appearance.Width = 208.000000000000000000
Appearance.Height = 44.000000000000000000
Appearance.PlaceOffset.X = 326.000000000000000000
end>
ItemAppearanceObjects.ItemEditObjects.ObjectsCollection = <
item
AppearanceObjectName = 'Text1'
AppearanceClassName = 'TTextObjectAppearance'
end>
OnItemClickEx = ListView1ItemClickEx
end
object Button1: TButton
Position.X = 592.000000000000000000
Position.Y = 24.000000000000000000
Size.Width = 161.000000000000000000
Size.Height = 57.000000000000000000
Size.PlatformDefault = False
Text = 'Button1'
OnClick = Button1Click
end
object FDMemTable1: TFDMemTable
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvSilentMode]
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired, uvAutoCommitUpdates]
UpdateOptions.CheckRequired = False
UpdateOptions.AutoCommitUpdates = True
Left = 576
Top = 128
object FDMemTable1CustomerID: TIntegerField
FieldName = 'CustomerID'
end
object FDMemTable1CustomerName: TStringField
FieldName = 'CustomerName'
Size = 30
end
end
object BindSourceDB1: TBindSourceDB
DataSet = FDMemTable1
ScopeMappings = <>
Left = 576
Top = 192
end
object BindSourceDB2: TBindSourceDB
DataSet = FDMemTable1
ScopeMappings = <>
Left = 576
Top = 248
end
object BindingsList1: TBindingsList
Methods = <>
OutputConverters = <>
Left = 20
Top = 5
end
end
If you set a breakpoint on the first line of your ListView1ItemClickEx method and then run the app and click between two items, you'll see that there is no ItemObject because you're not clicking on an item (you're clicking between them). This results in ItemObject being nil, and you then try to read the Text value from that unassigned object, causing the AV.
You can correct this by checking to make sure that ItemObject is assigned a value before you use it.
procedure TForm1.ListView1ItemClickEx(const Sender: TObject; ItemIndex: Integer;
const LocalClickPos: TPointF; const ItemObject: TListItemDrawable);
begin
if ItemObject <> nil then
begin
if itemobject.Name = 'Text1' then
begin
ShowMessage('clicked on Text1');
end else if itemobject.Name = 'Text2' then
begin
ShowMessage('clicked on Text2');
end;
end else
ShowMessage('ItemObject is not assigned');
end;
Learning to use the debugger to step through the code will enable you to figure out this sort of simple issue yourself. There's no better tool to have in your programmers toolbox than a good debugger, and Delphi's debugger is quite good.
Related
I notice that quality of images is poor when drawn smaller than the source image. This is especially obvious when the image contains thin lines as the subsampling causes parts of the lines to disappear. I'm looking for a way to improve the quality without compromising too much on runtime. So ideally I'd like it to be done on the GPU. Below is an example with 3 different methods. The last method is my own code, which shows what I'm trying to achieve but is not done on the GPU and so is too slow. It also won't work if I want to include some rotation as well as scale. I have also tried changing the HighSpeed flag in the DrawBitmap function, but it doesn't seem to make a difference.
Form:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 240
ClientWidth = 438
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object Image1: TImage
MultiResBitmap = <
item
end>
Position.X = 8.000000000000000000
Position.Y = 8.000000000000000000
end
object Image2: TImage
MultiResBitmap = <
item
end>
Position.X = 216.000000000000000000
Position.Y = 8.000000000000000000
end
object Image3: TImage
MultiResBitmap = <
item
end>
Position.X = 216.000000000000000000
Position.Y = 80.000000000000000000
end
object Image4: TImage
MultiResBitmap = <
item
end>
Position.X = 216.000000000000000000
Position.Y = 152.000000000000000000
end
object Label1: TLabel
Position.X = 266.000000000000000000
Position.Y = 24.000000000000000000
Size.Width = 164.000000000000000000
Size.Height = 17.000000000000000000
Size.PlatformDefault = False
Text = 'Scale destination rectangle'
TabOrder = 6
end
object Label2: TLabel
Position.X = 266.000000000000000000
Position.Y = 96.000000000000000000
Size.Width = 164.000000000000000000
Size.Height = 17.000000000000000000
Size.PlatformDefault = False
Text = 'Create canvas scale transform'
TabOrder = 5
end
object Label3: TLabel
Position.X = 266.000000000000000000
Position.Y = 168.000000000000000000
Size.Width = 164.000000000000000000
Size.Height = 17.000000000000000000
Size.PlatformDefault = False
Text = 'Hand coded Shrink function'
TabOrder = 4
end
end
Unit:
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Objects,
FMX.Controls.Presentation, FMX.StdCtrls;
type
PAlphaColorArray = ^TAlphaColorArray;
TAlphaColorArray = array[0..32767] of TAlphaColor;
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Image3: TImage;
Image4: TImage;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
procedure Shrink(const ABitmap : TBitmap ; out ABitmapOut : TBitmap);
var
Form1: TForm1;
implementation
uses Math, Math.Vectors;
{$R *.fmx}
procedure TForm1.FormCreate(Sender: TObject);
const
r : Single = 0.2;
size : Integer = 200;
var
srcRect, dstRect : TRectF;
bmp : TBitmap;
begin
// Create source image - circle
Image1.Bitmap.BitmapScale := 1;
Image1.Bitmap.SetSize(size, size);
Image1.Width := Image1.Bitmap.Width;
Image1.Height := Image1.Bitmap.Height;
if Image1.Bitmap.Canvas.BeginScene then begin
Image1.Bitmap.Canvas.Clear(TAlphaColorRec.White);
Image1.Bitmap.Canvas.Stroke.Thickness := 1;
Image1.Bitmap.Canvas.DrawEllipse(TRectF.Create(size/10,size/10,9*size/10,9*size/10), 1);
Image1.Bitmap.Canvas.EndScene;
end;
srcRect := Image1.Bitmap.BoundsF;
dstRect := srcRect;
dstRect.BottomRight := PointF(dstRect.Width*r, dstRect.Height*r);
// Try reducing by scaling the destination rectangle
// Same method as TBitmap.CreateThumbnail
Image2.Bitmap.BitmapScale := 1;
Image2.Bitmap.SetSize(Ceil(dstRect.Width), Ceil(dstRect.Height));
Image2.Width := Image2.Bitmap.Width;
Image2.Height := Image2.Bitmap.Height;
if Image2.Bitmap.Canvas.BeginScene then begin
Image2.Bitmap.Canvas.DrawBitmap(Image1.Bitmap, srcRect, dstRect, 1, True);
Image2.Bitmap.Canvas.EndScene;
end;
// Try reducing using the canvas transform matrix
Image3.Bitmap.BitmapScale := 1;
Image3.Bitmap.SetSize(Ceil(dstRect.Width), Ceil(dstRect.Height));
Image3.Width := Image2.Bitmap.Width;
Image3.Height := Image2.Bitmap.Height;
if Image3.Bitmap.Canvas.BeginScene then begin
Image3.Bitmap.Canvas.SetMatrix(TMatrix.CreateScaling(r, r));
Image3.Bitmap.Canvas.DrawBitmap(Image1.Bitmap, srcRect, srcRect, 1, True);
Image3.Bitmap.Canvas.EndScene;
end;
// Reduce using Shrink function - Slow (not done on GPU)
bmp := TBitmap.Create(Ceil(dstRect.Width), Ceil(dstRect.Height));
bmp.BitmapScale := 1;
Image4.Width := bmp.Width;
Image4.Height := bmp.Height;
Shrink(Image1.Bitmap, bmp);
Image4.Bitmap.Assign(bmp);
bmp.Free;
end;
// Shrink a bitmap using all available data from source
// Could be sped up a little for specific cases such as scaling by 0.5
procedure Shrink(const ABitmap : TBitmap ; out ABitmapOut : TBitmap);
Var
Lx, Ly : integer;
LyBox, LxBox, LyBox1, LyBox2, LxBox1, LxBox2 : integer;
TR, TG, TB, TA : integer;
LRowIn, LRowOut, LRowInStart : PAlphaColorArray;
LBoxCount : integer;
LRowBytes, LRowBytesIn : integer;
LBoxRows : array of PAlphaColorArray;
LRatioW, LRatioH : Real;
bdata, bdatao : TBitmapData;
begin
if (ABitmapOut.Width = 0) or (ABitmapOut.Height = 0) then Exit;
LRatioH := ABitmap.Height / ABitmapOut.Height;
LRatioW := ABitmap.Width / ABitmapOut.Width;
ABitmap.Map(TMapAccess.Read, bdata);
ABitmapOut.Map(TMapAccess.Write, bdatao);
try
SetLength(LBoxRows, Trunc(LRatioH)+1);
LRowOut := PAlphaColorArray(bdatao.GetScanline(0));
LRowBytes := bdatao.Pitch;
LRowBytesIn := bdata.Pitch;
LRowInStart := PAlphaColorArray(bdata.GetScanline(0));
for Ly := 0 to ABitmapOut.Height-1 do begin
LyBox1 := Trunc(Ly*LRatioH);
LyBox2 := Trunc((Ly+1)*LRatioH) - 1;
for LyBox := LyBox1 to LyBox2 do
PByte(LBoxRows[LyBox-LyBox1]) := PByte(LRowInStart) + LyBox*LRowBytesIn;
for Lx := 0 to ABitmapOut.Width-1 do begin
LxBox1 := Trunc(Lx*LRatioW);
LxBox2 := Trunc((Lx+1)*LRatioW) - 1;
TR := 0; TG := 0; TB := 0; TA := 0;
LBoxCount := 0;
for LyBox := LyBox1 to LyBox2 do begin
LRowIn := LBoxRows[LyBox-LyBox1];
for LxBox := LxBox1 to LxBox2 do begin
Inc(TB, TAlphaColorRec(LRowIn[LxBox]).B);
Inc(TG, TAlphaColorRec(LRowIn[LxBox]).G);
Inc(TR, TAlphaColorRec(LRowIn[LxBox]).R);
Inc(TA, TAlphaColorRec(LRowIn[LxBox]).A);
Inc(LBoxCount);
end;
end;
TAlphaColorRec(LRowOut[Lx]).B := TB div LBoxCount;
TAlphaColorRec(LRowOut[Lx]).G := TG div LBoxCount;
TAlphaColorRec(LRowOut[Lx]).R := TR div LBoxCount;
TAlphaColorRec(LRowOut[Lx]).A := TA div LBoxCount;
end;
Inc(PByte(LRowOut), LRowBytes);
end;
finally
ABitmap.Unmap(bdata);
ABitmapOut.Unmap(bdatao);
end;
end;
end.
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.
Starting from this layout at design time.
(It contains several TLayout, TGridPanelLayout, TText elements as example)
At runtime, I am saving the complete objects structure to a file using ObjectBinaryToText
But when loading the file back from the file using ObjectTextToBinary, I get this result
Why the sub-controls are not taking the exqct same layout as saved before?
The file structure seems to be OK and containing all sub-controls as described when saving my form with the IDE
Here is a piece of code demonstrating the problem.
PAS File
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
system.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics,
FMX.Dialogs, FMX.Objects, FMX.Layouts, FMX.Controls.Presentation,
FMX.StdCtrls;
type
TForm1 = class(TForm)
RecTop: TRectangle;
ButtonSave: TButton;
ButtonClear: TButton;
ButtonLoad: TButton;
Layout1: TLayout;
GridPanelLayout1: TGridPanelLayout;
Text1: TText;
Text2: TText;
Text3: TText;
Text4: TText;
procedure ButtonSaveClick(Sender: TObject);
procedure ButtonClearClick(Sender: TObject);
procedure ButtonLoadClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
AppPath: string;
AppDatFile: String;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
uses
System.IOUtils;
procedure TForm1.ButtonSaveClick(Sender: TObject);
var
FileStream : TFileStream;
MemStream : TMemoryStream;
begin
FileStream := TFileStream.Create(AppDatFile, fmCreate);
try
MemStream := TMemoryStream.Create;
MemStream.WriteComponent(Layout1);
MemStream.Position := 0;
ObjectBinaryToText(MemStream, FileStream);
finally
MemStream.Free;
FileStream.Free;
end;
end;
procedure TForm1.ButtonClearClick(Sender: TObject);
var
i: Integer;
begin
for i := pred(Layout1.ChildrenCount) downto 0 do
Layout1.Children[i].Free;
end;
procedure TForm1.ButtonLoadClick(Sender: TObject);
var
FileStream : TFileStream;
MemStream : TMemoryStream;
begin
if FileExists(AppDatFile) then
begin
FileStream := TFileStream.Create(AppDatFile, fmOpenRead);
try
MemStream := TMemoryStream.Create;
ObjectTextToBinary(FileStream, MemStream);
MemStream.Position := 0;
MemStream.ReadComponent(Layout1);
Layout1.Align:= TAlignLayout.Client;
finally
MemStream.Free;
FileStream.Free;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
AppPath:= TPath.GetLibraryPath;
AppDatFile:= TPath.Combine(AppPath, 'SaveLoadLayout.dat');
end;
end
FMX File
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object RecTop: TRectangle
Align = Top
Size.Width = 640.000000000000000000
Size.Height = 41.000000000000000000
Size.PlatformDefault = False
end
object ButtonSave: TButton
Position.X = 8.000000000000000000
Position.Y = 8.000000000000000000
TabOrder = 3
Text = 'Save'
OnClick = ButtonSaveClick
end
object ButtonClear: TButton
Position.X = 96.000000000000000000
Position.Y = 8.000000000000000000
TabOrder = 2
Text = 'Clear'
OnClick = ButtonClearClick
end
object ButtonLoad: TButton
Position.X = 184.000000000000000000
Position.Y = 8.000000000000000000
TabOrder = 1
Text = 'Load'
OnClick = ButtonLoadClick
end
object Layout1: TLayout
Align = Client
Size.Width = 640.000000000000000000
Size.Height = 439.000000000000000000
Size.PlatformDefault = False
TabOrder = 4
object GridPanelLayout1: TGridPanelLayout
Align = Client
Size.Width = 640.000000000000000000
Size.Height = 439.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
ColumnCollection = <
item
Value = 50.000000000000000000
end
item
Value = 50.000000000000000000
end>
ControlCollection = <
item
Column = 0
Control = Text1
Row = 0
end
item
Column = 1
Control = Text2
Row = 0
end
item
Column = 0
Control = Text3
Row = 1
end
item
Column = 1
Control = Text4
Row = 1
end>
RowCollection = <
item
Value = 50.000000000000000000
end
item
Value = 50.000000000000000000
end>
object Text1: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text1'
end
object Text2: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text2'
end
object Text3: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text3'
end
object Text4: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text4'
end
end
end
end
As I said in my comment, the problem is that WriteComponent wrongly write items with the format:
Control = Form1.Text1
This is not correct, it should be
Control = Text1
The behavior is maybe caused by the fact that serializing a component using other component, their owner is saved along.
The workaround is to correct what WriteComponent write. A simple implementation using a simple ReplaceString is like this:
procedure TForm1.ButtonSaveClick(Sender: TObject);
var
StringStream : TStringStream;
MemStream : TMemoryStream;
Buf : String;
begin
MemStream := nil;
StringStream := TStringStream.Create;
try
MemStream := TMemoryStream.Create;
MemStream.WriteComponent(Layout1);
MemStream.Position := 0;
ObjectBinaryToText(MemStream, StringStream);
Buf := StringReplace(StringStream.DataString,
' Control = ' + Self.Name + '.',
' Control = ', [rfReplaceAll]);
TFile.WriteAllText(AppDatFile, Buf);
finally
MemStream.Free;
StringStream.Free;
end;
end;
Be aware that this workaround implementation works for your example but could be confused because the search and replace do not use a real parser and could replace something else having the same form (A string property for example).
How to get the total ItemHeight (variably defined) of the items in the TListView at runtime.
The item height, by the way, is arbitrarily defined at runtime using the event UpdateObjects and I should be able to get it from there but I am not getting the correct height for some reasons. I feel it should be easier if I get those after it is defined.
I've tried this approach but no success. But my code ListView1.Items[i].Height looks not right here.
TotalItemHeight := 0;
for i = 0 to ListView1.Items.Count - 1 do
begin
TotalItemHeight := TotalItemHeight + ListView1.Items[i].Height; //I need help here..
end;
.FMX Procedure:
unit MainForm;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
System.Generics.Collections,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
FMX.Controls.Presentation, FMX.StdCtrls, FMX.ListView.Types,
FMX.ListView.Appearances, FMX.ListView.Adapters.Base, FMX.ListView,
Markov;
type
TVariableHeight = class(TForm)
Button1: TButton;
ListView1: TListView;
ToolBar1: TToolBar;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure ListView1UpdateObjects(const Sender: TObject;
const AItem: TListViewItem);
private
FChain: TChain;
FBitmaps: TDictionary<Integer, TBitmap>;
FText: TArray<string>;
procedure ReadText;
function GetDimensionBitmap(const Width, Height: Single): TBitmap;
public
function GetTextHeight(const D: TListItemText; const Width: Single; const Text: string): Integer;
destructor Destroy; override;
end;
var
VariableHeight: TVariableHeight;
implementation
uses
System.IOUtils, FMX.TextLayout;
{$R *.fmx}
// Create a new item with random text of random length
procedure TVariableHeight.Button1Click(Sender: TObject);
begin
ReadText;
ListView1.Items.Add.Data['txtMain'] := FText[Random(Length(FText))];
// with classic appearances, use Text property
//ListView1.Items.Add.Text := FChain.Generate(Random(100) + 5);
end;
function TVariableHeight.GetDimensionBitmap(const Width, Height: Single): TBitmap;
procedure Arrow(C: TCanvas; P: array of TPointF);
begin
C.DrawLine(P[0], P[1], 1.0);
C.DrawLine(P[0], P[2], 1.0);
C.DrawLine(P[0], P[3], 1.0);
end;
var
EndP1, EndP2: TPointF;
TextBitmap: TBitmap;
IntHeight: Integer;
begin
IntHeight := Trunc(Height);
if FBitmaps = nil then
FBitmaps := TDictionary<Integer, TBitmap>.Create;
if not FBitmaps.TryGetValue(IntHeight, Result) then
begin
Result := TBitmap.Create(Trunc(Width), IntHeight);
FBitmaps.Add(IntHeight, Result);
if Result.Canvas.BeginScene then
begin
Result.Canvas.Clear(TAlphaColorRec.Null);
Result.Canvas.Stroke.Color := TAlphaColorRec.Darkgray;
// Draw the arrows
EndP1 := TPointF.Create(Width/2, 0);
EndP2 := TPointF.Create(Width/2, Height);
Arrow(Result.Canvas,
[EndP1, TPointF.Create(Width/2, Height/2 - Width/2),
EndP1 + TPointF.Create(-2, 5), EndP1 + TPointF.Create(2, 5)]);
Arrow(Result.Canvas,
[EndP2, TPointF.Create(Width/2, Height/2 + Width/2),
EndP2 + TPointF.Create(-2, -5), EndP2 + TPointF.Create(2, -5)]);
// Draw the dimension text
TextBitmap := TBitmap.Create(Trunc(Width), Trunc(Width));
try
if TextBitmap.Canvas.BeginScene then
with TextBitmap.Canvas do
begin
Clear(TAlphaColorRec.Null);
Fill.Color := TAlphaColorRec.Darkgray;
FillText(TextBitmap.BoundsF, ''.Format('%d', [IntHeight]), False, 1,
[], TTextAlign.Center, TTextAlign.Center);
EndScene;
end;
TextBitmap.Rotate(90);
Result.Canvas.DrawBitmap(TextBitmap, TextBitmap.BoundsF,
TextBitmap.BoundsF.CenterAt(Result.BoundsF), 1);
finally
TextBitmap.Free;
end;
Result.Canvas.EndScene;
end;
end;
end;
destructor TVariableHeight.Destroy;
var
Key: Integer;
begin
FChain.Free;
if FBitmaps <> nil then
for Key in FBitmaps.Keys do
FBitmaps[Key].Free;
FBitmaps.Free;
inherited;
end;
// Calculate height for text drawable D
function TVariableHeight.GetTextHeight(const D: TListItemText; const Width: single; const Text: string): Integer;
var
Layout: TTextLayout;
begin
// Create a TTextLayout to measure text dimensions
Layout := TTextLayoutManager.DefaultTextLayout.Create;
try
Layout.BeginUpdate;
try
// Initialize layout parameters with those of the drawable
Layout.Font.Assign(D.Font);
Layout.VerticalAlign := D.TextVertAlign;
Layout.HorizontalAlign := D.TextAlign;
Layout.WordWrap := D.WordWrap;
Layout.Trimming := D.Trimming;
Layout.MaxSize := TPointF.Create(Width, TTextLayout.MaxLayoutSize.Y);
Layout.Text := Text;
finally
Layout.EndUpdate;
end;
// Get layout height
Result := Round(Layout.Height);
// Add one em to the height
Layout.Text := 'm';
Result := Result + Round(Layout.Height);
finally
Layout.Free;
end;
end;
procedure TVariableHeight.ListView1UpdateObjects(const Sender: TObject;
const AItem: TListViewItem);
var
Drawable: TListItemText;
SizeImg: TListItemImage;
Text: string;
AvailableWidth: Single;
begin
SizeImg := TListItemImage(AItem.View.FindDrawable('imgSize'));
AvailableWidth := TListView(Sender).Width - TListView(Sender).ItemSpaces.Left
- TListView(Sender).ItemSpaces.Right - SizeImg.Width;
ShowMessage(TListView(Sender).Height.ToString);
// Find the text drawable which is used to calcualte item size.
// For dynamic appearance, use item name.
// For classic appearances use TListViewItem.TObjectNames.Text
// Drawable := TListItemText(AItem.View.FindDrawable(TListViewItem.TObjectNames.Text));
Drawable := TListItemText(AItem.View.FindDrawable('txtMain'));
Text := Drawable.Text;
// Randomize the font when updating for the first time
if Drawable.TagFloat = 0 then
begin
Drawable.Font.Size := 1; // Ensure that default font sizes do not play against us
Drawable.Font.Size := 10 + Random(4) * 4;
Drawable.TagFloat := Drawable.Font.Size;
if Text.Length < 100 then
Drawable.Font.Style := [TFontStyle.fsBold];
end;
// Calculate item height based on text in the drawable
AItem.Height := GetTextHeight(Drawable, AvailableWidth, Text);
Drawable.Height := AItem.Height;
Drawable.Width := AvailableWidth;
SizeImg.OwnsBitmap := False;
SizeImg.Bitmap := GetDimensionBitmap(SizeImg.Width, AItem.Height);
end;
procedure TVariableHeight.ReadText;
const
Delimiters: array of char = [#10, #13];
var
Reader: TStreamReader;
Stream: TResourceStream;
begin
if Length(FText) = 0 then
begin
Stream := TResourceStream.Create(HInstance, 'Blabla', RT_RCDATA);
Reader := TStreamReader.Create(Stream);
try
FText := Reader.ReadToEnd.Split(Delimiters, TStringSplitOptions.ExcludeEmpty)
finally
Reader.Close;
Reader.Free;
Stream.Free;
end;
end;
end;
end.
.FMX File
object VariableHeight: TVariableHeight
Left = 0
Top = 0
Caption = 'VariableHeight'
ClientHeight = 480
ClientWidth = 510
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object ListView1: TListView
ItemAppearanceClassName = 'TDynamicAppearance'
ItemEditAppearanceClassName = 'TDynamicAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
OnUpdateObjects = ListView1UpdateObjects
Align = Client
Size.Width = 510.000000000000000000
Size.Height = 436.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
ItemAppearanceObjects.ItemObjects.ObjectsCollection = <
item
AppearanceObjectName = 'txtMain'
AppearanceClassName = 'TTextObjectAppearance'
Appearance.TextAlign = Leading
Appearance.WordWrap = True
Appearance.Height = 44.000000000000000000
Appearance.VertAlign = Center
end
item
AppearanceObjectName = 'imgSize'
AppearanceClassName = 'TImageObjectAppearance'
Appearance.ScalingMode = Original
Appearance.Width = 30.000000000000000000
Appearance.Align = Trailing
end>
ItemAppearanceObjects.ItemEditObjects.ObjectsCollection = <
item
AppearanceObjectName = 'Text1'
AppearanceClassName = 'TTextObjectAppearance'
end>
end
object ToolBar1: TToolBar
Padding.Top = 4.000000000000000000
Padding.Bottom = 4.000000000000000000
Size.Width = 510.000000000000000000
Size.Height = 44.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
object Label1: TLabel
Align = Contents
Size.Width = 510.000000000000000000
Size.Height = 44.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'toollabel'
TextSettings.HorzAlign = Center
Text = 'Variable Row Height Demo'
end
object Button1: TButton
Align = Right
Margins.Right = 5.000000000000000000
Position.X = 448.000000000000000000
Position.Y = 4.000000000000000000
Size.Width = 57.000000000000000000
Size.Height = 36.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'listitembutton'
TabOrder = 1
Text = 'Fill List'
OnClick = Button1Click
end
end
end
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.