Spinning image in Delphi - delphi

I am testing how to spin image in Delphi (on Android). For some reason it works only if I move two fingers on the screen. And the rotation isn't smooth. Ideally on-clik on the image with one finger I would like to have the image spinning until it's stopped by another click. Also, is there a better more Delphi like way to achieve this? I have this code (RAD Delphi 10.4):
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.Colors, System.IOUtils, FMX.Gestures, System.Math, FMX.Media;
type
TForm1 = class(TForm)
ColorBox1: TColorBox;
ColorBox2: TColorBox;
ColorBox3: TColorBox;
ColorBox4: TColorBox;
ColorBox5: TColorBox;
ColorBox6: TColorBox;
Image1: TImage;
GestureManager1: TGestureManager;
MediaPlayer1: TMediaPlayer;
procedure ColorBox1Click(Sender: TObject);
procedure ColorBox2Click(Sender: TObject);
procedure ColorBox3Click(Sender: TObject);
procedure ColorBox4Click(Sender: TObject);
procedure ColorBox5Click(Sender: TObject);
procedure ColorBox6Click(Sender: TObject);
procedure Image1Gesture(Sender: TObject; const EventInfo: TGestureEventInfo;
var Handled: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
{$R *.LgXhdpiPh.fmx ANDROID}
procedure TForm1.ColorBox1Click(Sender: TObject);
var
number: Integer;
stop: Boolean;
begin
//Image1.Bitmap.LoadFromFile('../../images/black.png')
Image1.Bitmap.LoadFromFile(TPath.GetDocumentsPath + PathDelim + 'black.png');
MediaPlayer1.FileName := TPath.Combine(TPath.GetDocumentsPath, 'spinner.3gp');
MediaPlayer1.Play;
end;
procedure TForm1.ColorBox2Click(Sender: TObject);
begin
//Image1.Bitmap.LoadFromFile('../../images/blue.png')
Image1.Bitmap.LoadFromFile(TPath.GetDocumentsPath + PathDelim + 'blue.png');
end;
procedure TForm1.ColorBox3Click(Sender: TObject);
begin
//Image1.Bitmap.LoadFromFile('../../images/red.png')
Image1.Bitmap.LoadFromFile(TPath.GetDocumentsPath + PathDelim + 'red.png');
end;
procedure TForm1.ColorBox4Click(Sender: TObject);
begin
//Image1.Bitmap.LoadFromFile('../../images/green.png')
Image1.Bitmap.LoadFromFile(TPath.GetDocumentsPath + PathDelim + 'green.png');
end;
procedure TForm1.ColorBox5Click(Sender: TObject);
begin
//Image1.Bitmap.LoadFromFile('../../images/yellow.png')
Image1.Bitmap.LoadFromFile(TPath.GetDocumentsPath + PathDelim + 'yellow.png');
end;
procedure TForm1.ColorBox6Click(Sender: TObject);
begin
//Image1.Bitmap.LoadFromFile('../../images/pink.png')
Image1.Bitmap.LoadFromFile(TPath.GetDocumentsPath + PathDelim + 'pink.png');
end;
procedure TForm1.Image1Gesture(Sender: TObject;
const EventInfo: TGestureEventInfo; var Handled: Boolean);
var
LObj: IControl;
image: TImage;
begin
LObj := Self.ObjectAtPoint(ClientToScreen(EventInfo.Location));
if LObj is TImage then
begin
image := TImage(LObj.GetObject);
image.RotationAngle := RadToDeg(-EventInfo.Angle);
end;
end;
end.

It's better to use TImage's OnClick event instead of Gesture, I suppose.
const
RotationDelta = 0.5;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := false; //to disable rotation
Timer1.Interval := 20;
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
Timer1.Enabled := not Timer1.Enabled; //Timer.Interval should be 20-30 ms
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Image1.RotationAngle := Image1.RotationAngle + RotationDelta; //rotate image
end;
It's not very good implementation because TTimer is not very acurate, but it's good enough for general purpose. If you want slower or faster rotating you should change RotationDelta respectively.
But my advice will only work if you want to enable/disable rotation by clicking image, not while sliding.
P.S. Checked this solution on Delphi 10.1, but on Windows only.

Related

How can I do PING threads, reading OnReply event in Delphi 6?

I have a problem with Delphi 6 and Indy's TIdIcmpClient component.
I get this message when compiling the following code, in the marked line (51):
FPing.OnReply := OnPingReply;
[Error] fire.pas(51): Incompatible types: 'TComponent' and 'TIdIcmpClient'
How should I fix it?
unit fire;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdRawBase, IdRawClient,
IdIcmpClient;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TMyThread = class(TThread)
private
FIndex: Integer;
FPing: TIdIcmpClient;
FIP: string;
protected
procedure Execute; override;
procedure OnPingReply(ASender: TIdIcmpClient; AReplyStatus: TReplyStatus);
public
constructor Create(AIndex: Integer);
destructor Destroy; override;
end;
constructor TMyThread.Create(AIndex: Integer);
begin
inherited Create(False);
FIndex := AIndex;
FIP := '192.168.1.' + IntToStr(FIndex + 1);
FPing := TIdIcmpClient.Create(nil);
FPing.Host:=FIP;
FPing.ReceiveTimeout:=1500;
FPing.OnReply := OnPingReply;
end;
destructor TMyThread.Destroy;
begin
FPing.Free;
inherited;
end;
//var// icmp:array[0..10] of TIdIcmpClient;
// ip:string;
procedure TMyThread.Execute; // aici e ce face thread-ul
var
i: Integer;
begin
FPing.Ping;
// ICMP.Ping('a',1000);
// Sleep(1300);
// form1.memo1.lines.add(IntToStr(findex)+' '+ICMP.ReplyStatus.fromipaddress);
for i := 1 to 1 do
begin
// 'findex' este indexul thread-ului din matrice
form1.memo1.lines.add(inttostr(findex)+' Thread running...');
application.ProcessMessages;
Sleep(1000);
end;
end;
procedure TMyThread.OnPingReply(ASender: TIdIcmpClient; AReplyStatus: TReplyStatus);
begin
if AReplyStatus.BytesReceived > 0 then
form1.memo1.Lines.add(FIP+ ' is reachable')
else
form1.memo1.Lines.add(FIP+ ' is not reachable: ');
end;
procedure TForm1.Button1Click(Sender: TObject);
var
MyThreads: array[0..10] of TMyThread;
// icmp:array[0..10] of TIdIcmpClient;
i: Integer;
begin
{ for i := 0 to 10 do //10 fire
begin
icmp[i]:=tidicmpclient.create(nil);
icmp[i].ReceiveTimeout:=1200;
ip:=Format('%s.%d', ['192.168.1', i]);
ICMP[i].Host :=ip;
end; }
for i := 0 to 10 do //10 fire
begin
MyThreads[i] := TMyThread.Create(i);
MyThreads[i].Resume;
application.ProcessMessages;
end;
// Readln;
for i := 0 to 10 do
begin
MyThreads[i].Free;
// icmp[i].Free;
end;
end;
end.
I expected it to be compilable, but I don't see the reason why it is not.
Your event handler is declared wrong. The ASender parameter needs to be TComponent rather than TIdIcmpClient, and the AReplyStatus parameter needs to be const:
procedure OnPingReply(ASender: TComponent; const AReplyStatus: TReplyStatus);
That being said, you don't need to use the OnReply event at all in this situation. TIdIcmpClient operates synchronously, so you can simply use the TIdIcmpClient.ReplyStatus property after the TIdIcmpClient.Ping() method exits:
procedure TMyThread.Execute; // aici e ce face thread-ul
var
...
begin
FPing.Ping;
if FPing.ReplyStatus.BytesReceived > 0 then
...
else
...
...
end;
Also, you must synchronize with the main UI thread when accessing UI controls in a worker thread. You can use TThread.Synchronize() method for that.
And, you do not need to call Application.ProcessMessages() in a worker thread. Doing so will have no effect on the main UI thread.
With all of that said, try something more like this:
unit fire;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdRawBase, IdRawClient,
IdIcmpClient;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure AddText(const AText: String);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TMyThread = class(TThread)
private
FIndex: Integer;
FPing: TIdIcmpClient;
FIP: string;
FText: String;
procedure AddTextToUI(const AText: String);
procedure DoSyncText;
protected
procedure Execute; override;
public
constructor Create(AIndex: Integer);
destructor Destroy; override;
end;
constructor TMyThread.Create(AIndex: Integer);
begin
inherited Create(False);
FIndex := AIndex;
FIP := '192.168.1.' + IntToStr(FIndex + 1);
FPing := TIdIcmpClient.Create(nil);
FPing.Host := FIP;
FPing.ReceiveTimeout := 1500;
end;
destructor TMyThread.Destroy;
begin
FPing.Free;
inherited;
end;
procedure TMyThread.AddTextToUI(const AText: String);
begin
FText := AText;
Synchronize(DoSyncText);
end;
procedure TMyThread.DoSyncText;
begin
Form1.AddText(FText);
end;
procedure TMyThread.Execute; // aici e ce face thread-ul
begin
AddTextToUI(IntToStr(FIndex) + ' Thread running...');
try
FPing.Ping;
except
AddTextToUI('Error pinging ' + FIP);
Exit;
end;
if FPing.ReplyStatus.BytesReceived > 0 then
AddTextToUI(FIP + ' is reachable')
else
AddTextToUI(FIP + ' is not reachable');
end;
procedure TForm1.Button1Click(Sender: TObject);
var
MyThreads: array[0..10] of TMyThread;
I: Integer;
begin
for I := Low(MyThreads) to High(MyThreads) do //10 fire
begin
MyThreads[I] := TMyThread.Create(I);
end;
for I := Low(MyThreads) to High(MyThreads) do
begin
MyThreads[i].WaitFor;
MyThreads[i].Free;
end;
end;
procedure TForm1.AddText(const AText: String);
begin
Memo1.Lines.Add(AText);
end;
end.

How to play wav file from the resources

I need to play and loop a WAV audio track from resources.
I found an answer to a similar question here: https://stackoverflow.com/a/47960211/19160533
But when I paste it into my code, it says this:
My resources look like this (don't mind the name of the project):
The code I pasted into my project is:
procedure TForm1.FormShow(Sender: TObject);
begin
PlaySound(BG, 0, SND_RESOURCE or SND_ASYNC);
end;
And the whole thing looks like this:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.pngimage, Vcl.ExtCtrls, Unit2, Unit3, Unit4, Unit5,
Vcl.MPlayer, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
MediaPlayer1: TMediaPlayer;
Button1: TButton;
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure MediaPlayer1Enter(Sender: TObject);
procedure MediaPlayer1Notify(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormShow(Sender: TObject);
begin
PlaySound(BG, 0, SND_RESOURCE or SND_ASYNC);
end;
Maybe I need to include some library or something else? I'm new to Delphi.
To use PlaySound() in Delphi, you simply need to add the Winapi.MMSystem unit to your uses clause.
But, since you also have a TMediaPlayer in your project, you could use that instead of PlaySound(), which would have the extra benefit of giving you more control over the playback (pausing/resuming, skipping, etc).
TMediaPlayer does not natively support playing WAV audio from a resource, but it can be done with a little extra coding.
Internally, TMediaPlayer uses MCI via the mciSendCommand() function. According to Microsoft (HOWTO: Use MCI to Play AVI/WAVE Files from Memory), you can setup MCI to play WAV audio from memory (such as a resource) by installing a custom IO callback, and then specifying that callback when opening the player device. Fortunately, the callback is triggered by file extension, hence this approach is compatible with the TMediaPlayer.FileName property.
So, you should be able to write an IO callback function with a custom file extension (for example, .RES for resource), and have that callback load the WAV resource and read its data, and then you would set MediaPlayer1.DeviceType to dtWaveAudio and MediaPlayer1.FileName to a filename ending with the custom extension. The rest is handled by the OS for you, and you can then use MediaPlayer1 to control the playback as needed.
For example (untested, might need some tweaking):
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.pngimage, Vcl.ExtCtrls, Unit2, Unit3, Unit4, Unit5,
Vcl.MPlayer, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
MediaPlayer1: TMediaPlayer;
Button1: TButton;
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure MediaPlayer1Enter(Sender: TObject);
procedure MediaPlayer1Notify(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
Winapi.MMSystem;
{$R *.dfm}
function MAKEFOURCC(ch0, ch1, ch2, ch3: BYTE): FOURCC;
begin
Result := DWORD(ch0) or (DWORD(ch1) shl 8) or (DWORD(ch2) shl 16) or (DWORD(ch3) shl 24);
end;
function MyResourceIOProc(lpMMIOInfo: PMMIOInfo; uMessage: UINT; lParam1, lParam2: LPARAM): LRESULT; stdcall;
var
Res: TResourceStream;
function GetResourceStream: TResourceStream;
begin
Move(lpMMIOInfo.adwInfo, Result, SizeOf(TResourceStream));
end;
procedure SetResourceStream(Stream: TResourceStream);
begin
Move(Stream, lpMMIOInfo.adwInfo, SizeOf(TResourceStream));
end;
begin
case uMessage of
MMIOM_OPEN: begin
try
Res := TResourceStream.Create(HInstance, ChangeFileExt(PChar(lParam1), ''), 'WAVE');
except
SetResourceStream(nil);
Exit(MMIOM_CANNOTOPEN);
end;
SetResourceStream(Res);
lpMMIOInfo.lDiskOffset := 0;
Exit(MMSYSERR_NOERROR);
end;
MMIOM_CLOSE: begin
Res := GetResourceStream;
SetResourceStream(nil);
Res.Free;
Exit(MMSYSERR_NOERROR);
end;
MMIOM_READ: begin
Res := GetResourceStream;
Move((PByte(Res.Memory) + lpMMIOInfo.lDiskOffset)^, Pointer(lParam1)^, lParam2);
Inc(lpMMIOInfo.lDiskOffset, lParam2);
Exit(lParam2);
end;
MMIOM_SEEK: begin
case lParam2 of
SEEK_SET: begin
lpMMIOInfo.lDiskOffset := lParam1;
end;
SEEK_CUR: begin
Inc(lpMMIOInfo.lDiskOffset, lParam1);
end;
SEEK_END: begin
Res := GetResourceStream;
lpMMIOInfo.lDiskOffset := Res.Size - 1 - lParam1;
end;
end;
Exit(lpMMIOInfo.lDiskOffset);
end;
else
Exit(MMSYSERR_NOERROR);
end;
end;
var
ccRES: FOURCC;
procedure TForm1.FormCreate(Sender: TObject);
begin
ccRES := MAKEFOURCC(Ord('R'), Ord('E'), Ord('S'), Ord(' '));
mmioInstallIOProc(ccRES, TFNMMIOProc(MyResourceIOProc), MMIO_INSTALLPROC or MMIO_GLOBALPROC);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
mmioInstallIOProc(ccRES, nil, MMIO_REMOVEPROC);
end;
procedure TForm1.FormShow(Sender: TObject);
begin
MediaPlayer1.FileName := 'BG.RES+';
MediaPlayer1.Open;
MediaPlayer1.Play;
end;

How To Record A Video And Audio Through Device, Firemonkey?

My Code for video recording is given, the recording is not in a smooth way i.e. the place where I turn my camera appears on the preview view late. How I can resolve this issue
unit VideoAttachmentUnit;
interface
uses
System.SysUtils,
System.Types,
System.UITypes,
System.Classes,
System.Variants,
FMX.Types,
FMX.Controls,
FMX.Forms,
FMX.Dialogs,
FMX.StdCtrls,
FMX.Media,
FMX.Platform,
FMX.Objects,
FMX.Layouts,
FMX.Memo,
FMX.Controls.Presentation;
type
TVideoAttachmentForm = class(TForm)
NavBar: TToolBar;
CameraChangeBtn: TButton;
PlayBtn: TButton;
CloseScreenBtn: TButton;
ToolBar1: TToolBar;
StartRecordingBtn: TButton;
StopRecordingBtn: TButton;
ImageCameraView: TImage;
CameraComponent: TCameraComponent;
procedure FormCreate(Sender: TObject);
procedure CloseScreenBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure CameraChangeBtnClick(Sender: TObject);
procedure StartRecordingBtnClick(Sender: TObject);
procedure StopRecordingBtnClick(Sender: TObject);
procedure CameraComponentSampleBufferReady(Sender: TObject;
const ATime: TMediaTime);
private
{ Private declarations }
procedure GetImage;
procedure InitialSettingsForTheRecording;
public
function AppEvent(AAppEvent: TApplicationEvent; AContext: TObject): Boolean;
end;
var
VideoAttachmentForm: TVideoAttachmentForm;
WhichCamera:String;
procedure DisplayTheVideoAttachmentScreen;
implementation
{$R *.fmx}
procedure DisplayTheVideoAttachmentScreen;
begin
try
Application.CreateForm(TVideoAttachmentForm , VideoAttachmentForm);
VideoAttachmentForm.Show;
finally
end;
end;
procedure TVideoAttachmentForm.CameraChangeBtnClick(Sender: TObject);
var
LActive: Boolean;
begin
{ Select Back Camera }
LActive := CameraComponent.Active;
try
CameraComponent.Active := False;
if WhichCamera = 'BackCamera' then
begin
CameraComponent.Kind := TCameraKind.FrontCamera;
WhichCamera := 'FrontCamera';
end
else if WhichCamera = 'FrontCamera' then
begin
CameraComponent.Kind := TCameraKind.BackCamera;
WhichCamera := 'BackCamera';
end;
finally
CameraComponent.Active := LActive;
end;
end;
procedure TVideoAttachmentForm.CameraComponentSampleBufferReady(Sender: TObject;
const ATime: TMediaTime);
begin
TThread.Synchronize(TThread.CurrentThread, GetImage);
ImageCameraView.Width := ImageCameraView.Bitmap.Width;
ImageCameraView.Height := ImageCameraView.Bitmap.Height;
end;
procedure TVideoAttachmentForm.CloseScreenBtnClick(Sender: TObject);
begin
VideoAttachmentForm.Close;
end;
procedure TVideoAttachmentForm.FormCreate(Sender: TObject);
var
AppEventSvc: IFMXApplicationEventService;
begin
if TPlatformServices.Current.SupportsPlatformService(IFMXApplicationEventService, IInterface(AppEventSvc)) then
AppEventSvc.SetApplicationEventHandler(AppEvent);
end;
procedure TVideoAttachmentForm.FormShow(Sender: TObject);
begin
InitialSettingsForTheRecording;
end;
function TVideoAttachmentForm.AppEvent(AAppEvent: TApplicationEvent; AContext: TObject): Boolean;
begin
case AAppEvent of
TApplicationEvent.WillBecomeInactive:
CameraComponent.Active := False;
TApplicationEvent.EnteredBackground:
CameraComponent.Active := False;
TApplicationEvent.WillTerminate:
CameraComponent.Active := False;
end;
end;
procedure TVideoAttachmentForm.InitialSettingsForTheRecording;
var
LSettings: TVideoCaptureSetting;
begin
CameraComponent.Kind := TCameraKind.BackCamera;
WhichCamera := 'BackCamera';
if CameraComponent.HasTorch then
begin
CameraComponent.TorchMode := TTorchMode.ModeAuto;
end;
CameraComponent.Quality := TVideoCaptureQuality.CaptureSettings;
CameraComponent.CaptureSettingPriority := TVideoCaptureSettingPriority.FrameRate;
end;
procedure TVideoAttachmentForm.StartRecordingBtnClick(Sender: TObject);
begin
CameraComponent.Active := True;
end;
procedure TVideoAttachmentForm.StopRecordingBtnClick(Sender: TObject);
begin
CameraComponent.Active := False;
end;
procedure TVideoAttachmentForm.GetImage;
begin
CameraComponent.SampleBufferToBitmap(ImageCameraView.Bitmap, True);
end;
end.

Delphi Created Images are not displayed

I am trying to dynamiclly create a custom component with images and display them in a Grid , but the Images don't show up. Below is the code with omitted part of declarations , could someone help me and tell me what am I doint wrong ?
Custom component Class
unit Tile;
interface
uses FMX.Controls, FMX.StdCtrls, System.Classes, FMX.Types, System.StrUtils ,
System.SysUtils, System.Types, System.UITypes,
System.Variants,
FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Ani,
FMX.Objects, FMX.Layouts;
type
TTileType = (Slider, Memory, Tile3D);
TTile = class
private
FOnChangedText: TNotifyEvent;
FType: TTileType;
FControl: TComponent;
FText: String;
FName: String;
FBitmap : TBitmap;
FAlign : TAlignLayout;
procedure TextChangedDefault(Sender: TObject);
protected
procedure SetText(aText: String);
procedure TextChanged; virtual;
procedure SetControlOnClick(AProc: TNotifyEvent);
function GetControlOnClick: TNotifyEvent;
procedure SetControlName(aName: String);
procedure SetBitmap(bitmap:TBitmap);
procedure SetAlign(align :TAlignLayout);
public
constructor Create(AParent: TFmxObject; AType: TTileType);
destructor Destroy; override;
published
property Text: String read FText write SetText;
property Name: String read FName write SetControlName;
property Bitmap:TBitmap read FBitmap write SetBitmap;
property Align:TAlignLayout read FAlign write SetAlign;
property OnChangedText: TNotifyEvent read FOnChangedText
write FOnChangedText;
property OnClick: TNotifyEvent read GetControlOnClick
write SetControlOnClick;
end;
implementation
constructor TTile.Create(AParent: TFmxObject; AType: TTileType);
begin
FType := AType;
case FType of
Slider:
begin
FControl := TButton.Create(AParent as TComponent);
FOnChangedText := TextChangedDefault;
(FControl as TFmxObject).Parent := AParent;
end;
Memory:
begin
FControl := TImage.Create(AParent as TComponent);
FOnChangedText := TextChangedDefault;
(FControl as TFmxObject).Parent := AParent;
end;
Tile3D:
FControl := nil;
else
FControl := nil;
end;
FName := FControl.Name;
end;
destructor TTile.Destroy;
begin
FControl.DisposeOf;
inherited;
end;
function TTile.GetControlOnClick: TNotifyEvent;
begin
case FType of
Slider:
begin
Result := (FControl as TButton).OnClick;
end;
Memory:
begin
Result := (FControl as TImage).OnClick;
end;
Tile3D:
begin
// TODO
end;
else
Result := nil;
end;
end;
procedure TTile.SetControlName(aName: String);
begin
FName := aName;
FControl.Name := aName;
end;
procedure TTile.SetBitmap(bitmap :TBitmap);
begin
FBitmap:=bitmap;
end;
procedure TTile.SetAlign(align :TAlignLayout);
begin
FAlign:=align;
end;
procedure TTile.SetControlOnClick(AProc: TNotifyEvent);
begin
case FType of
Slider:
begin
(FControl as TButton).OnClick := AProc;
end;
Memory:
begin
(FControl as TImage).OnClick := AProc;
end;
Tile3D:
begin
// TODO
end;
end;
end;
procedure TTile.SetText(aText: String);
begin
FText := aText;
TextChanged;
end;
procedure TTile.TextChanged;
begin
if Assigned(FOnChangedText) then
FOnChangedText(Self);
end;
procedure TTile.TextChangedDefault(Sender: TObject);
begin
(FControl as TButton).Text := FText;
end;
end.
Memory Game Class:
unit MemoryGame;
interface
uses Tile, Consts, FMX.Controls, FMX.StdCtrls, FMX.Layouts, System.Classes,
FMX.Types, System.Types, FMX.Graphics, System.SysUtils, FMX.Dialogs,Helper,FMX.ExtCtrls ,
System.UITypes,
System.Variants,
FMX.Forms,
FMX.TabControl, SliderPuzzle, System.Actions,
FMX.ActnList, FMX.StdActns, FMX.MultiView, FMX.Controls.Presentation, FMX.Edit,
DateUtils ,FMX.Objects ;
type
TMemoryGame = class(TGridLayout)
private
FTiles: TArray<TTile>;
procedure FillGrid(aTileNo: Integer);
protected
public
constructor Create(AParent: TFmxObject; aTileNo: Integer); reintroduce;
end;
var
moveCounter : Integer = 0 ;
implementation
{ MemoryGame }
constructor TMemoryGame.Create(AParent: TFmxObject; aTileNo: Integer);
begin
inherited Create(nil);
Parent := AParent;
FillGrid(aTileNo);
end;
procedure TMemoryGame.FillGrid(aTileNo: Integer);
var
I: Integer;
LTile: TTile;
begin
SetLength(FTiles, aTileNo);
for I := 0 to aTileNo - 1 do
begin
LTile := TTile.Create(Self, TTileType.Memory);
FTiles[I] := LTile;
if I = 0 then
begin
LTile.Bitmap:= TBitmap.CreateFromFile('../../img/img1.bmp');
LTile.Align := TAlignLayout.Client;
LTile.Align := TAlignLayout.Center;
end
else
begin
LTile.Bitmap:= TBitmap.CreateFromFile('../../img/img1.bmp');
LTile.Align := TAlignLayout.Client;
LTile.Align := TAlignLayout.Center;
end;
end;
end;
end.
Main Form:
unit MainForm;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
System.Variants, Consts,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, FMX.ExtCtrls,
FMX.Layouts, FMX.TabControl, SliderPuzzle, System.Actions,
FMX.ActnList, FMX.StdActns, FMX.MultiView, FMX.Controls.Presentation, FMX.Edit,
DateUtils,MemoryGame, FMX.Objects;
type
TFormMain = class(TForm)
tcMain: TTabControl;
ti1Slider: TTabItem;
ti2Runtime: TTabItem;
ti4Game3D: TTabItem;
ti3Memory: TTabItem;
GridLayout: TGridLayout;
bTile1: TButton;
bTile2: TButton;
bTile3: TButton;
bTile4: TButton;
bTile5: TButton;
bTile6: TButton;
bTile7: TButton;
bTile8: TButton;
bTile9: TButton;
bTile10: TButton;
bTile11: TButton;
bTile12: TButton;
bTile13: TButton;
bTile14: TButton;
bTile15: TButton;
bTileEmpty: TButton;
bNew: TButton;
MultiView: TMultiView;
bExitApp: TButton;
ActionList: TActionList;
FileExitActn: TFileExit;
NewGameActn: TAction;
StyleBook: TStyleBook;
hitCountLabel: TLabel;
movesCounter: TLabel;
TimeCountLabel: TLabel;
timer: TLabel;
Timer1: TTimer;
procedure bTileClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure NewGameActnExecute(Sender: TObject);
procedure GridLayoutResize(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FormMain: TFormMain;
Slider: TSliderPuzzle;
Memory : TMemoryGame;
firstMove : Boolean = true;
stop, elapsed : TDateTime ;
start : TDateTime = 0 ;
implementation
{$R *.fmx}
procedure TFormMain.NewGameActnExecute(Sender: TObject);
begin
if ti1Slider.IsSelected then
repeat
begin
firstMove:=true;
Slider.ShuffleTiles(GridLayout);
Slider.resetMoveCounter;
Timer1.Enabled := true;
Timer1.Interval :=1000;
Slider.resetTimer(start);
movesCounter.Text := IntToStr(Slider.GetMoveCount);
timer.Text := '--/--/--';
end;
until not Slider.IsGameOver(GridLayout)
else if ti2Runtime.IsSelected then
repeat
Slider.ShuffleTiles
until not Slider.IsGameOver;
end;
procedure TFormMain.Timer1Timer(Sender: TObject);
var myVar:Integer;
begin
if start<>0 then
begin
myVar := SecondsBetween(start,Now);
timer.Text :=Format('%.2d:%.2d', [myVar div 60, myVar mod 60]); ;
end;
end;
procedure TFormMain.bTileClick(Sender: TObject);
begin
if firstMove then
begin
Slider.startCount(start);
firstMove:=false;
end;
Slider.incrementCounter;
movesCounter.Text := IntToStr(Slider.GetMoveCount);
Slider.SwapTiles(GridLayout, Sender as TButton, bTileEmpty);
if Slider.IsGameOver(GridLayout) then
begin
Slider.resetMoveCounter;
Slider.resetTimer(start);
// movesCounter.Text := IntToStr(Slider.GetMoveCount);
// timer.Text := '--/--/--';
Timer1.Enabled := false;
ShowMessage('GAME OVER');
firstMove:=true;
ti3Memory.Enabled := true;
ti3Memory.TabControl.SetActiveTabWithTransition(ti3Memory,TTabTransition.Slide);
end;
end;
procedure TFormMain.GridLayoutResize(Sender: TObject);
begin
GridLayout.ItemHeight := GridLayout.Height / COLS-25;
GridLayout.ItemWidth := GridLayout.Width / ROWS;
end;
procedure TFormMain.FormShow(Sender: TObject);
begin
ReportMemoryLeaksOnShutdown := true;
Slider := TSliderPuzzle.Create(Self.ti2Runtime, TILES);
Slider.Height := GridLayout.Height;
Slider.Width := GridLayout.Width;
Slider.Align := TAlignLayout.Client;
//PuzzleGame
ReportMemoryLeaksOnShutdown := true;
Memory := TMemoryGame.Create(Self.ti3Memory, TILES);
Memory.Height := GridLayout.Height;
Memory.Width := GridLayout.Width;
Memory.Align := TAlignLayout.Client;
end;
end.
Call the assign() method of the FBitmap variable inside youe Set procedure:
procedure TTile.SetBitmap(bitmap :TBitmap);
begin
FBitmap.Assign(bitmap);
end;
Adding the following code to Tile class , fixed the issues.
type
private
FOnChangedBitmap : TNotifyEvent;
protected
procedure BitmapChanged;virtual;
procedure TTile.BitmapChanged;
begin
if Assigned(FOnChangedBitmap) then
FOnChangedBitmap(Self);
end;
procedure TTile.BitmapChangedDefault(Sender: TObject);
begin
(FControl as TImage).Bitmap := FBitmap;
end;
procedure TTile.SetBitmap(bitmap :TBitmap);
begin
FBitmap:=bitmap;
BitmapChanged;
end;
This all looks very complicated and perhaps it is.
But I solved a similar problem by simply setting the parent of the image:
Fheart := TImage.Create(self);
Fheart.Parent := self;
Fheart.SetSubComponent(true);
It seems unneccessary setting the parent when that is passed as the owner in the constructor - but it did solve my problem

Right Scrolling text

I am having one Delphi XE2 Project to display scrolling text (better "Marquee Text").
In my project I am having Timer1, Timer2, Button1, Button2, Label1 and Label2.
My object is to display some left scrolling text on Label1 after Button1.Click using Timer1 and some right scrolling text on Label2 after Button1.Click using Timer2.
I have defined the following codes:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Button1: TButton;
Button2: TButton;
Timer1: TTimer;
Timer2: TTimer;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := true;
Timer2.Enabled := true;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Timer1.Enabled := false;
Timer2.Enabled := false;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Interval := 100;
Timer2.Interval := 100;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
const
{$WRITEABLECONST ON}
ScrollingText : string = 'This is left scrolling text ';
{$WRITEABLECONST OFF}
var
ScrollPosition: Integer;
begin
Label1.Caption := ScrollingText;
for ScrollPosition := 1 to (Length(ScrollingText) - 1) do
begin
ScrollingText[ScrollPosition] := Label1.Caption[ScrollPosition + 1];
ScrollingText[Length(ScrollingText)] := Label1.Caption[1];
end;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
const
{$WRITEABLECONST ON}
ScrollingText : string = 'This is right scrolling text ';
{$WRITEABLECONST OFF}
var
ScrollPosition: Integer;
begin
Label2.Caption := ScrollingText;
for ScrollPosition := (Length(ScrollingText) - 1) to 1 do
begin
ScrollingText[ScrollPosition] := Label2.Caption[ScrollPosition - 1];
ScrollingText[Length(ScrollingText)] := Label2.Caption[1];
end;
end;
end.
My problem is that Left Scrolling is happening using Timer1 but Right Scrolling is not happening using Timer2.
The for loop in Timer2Timer should run down instead of up:
procedure TForm1.Timer2Timer(Sender: TObject);
const
{$WRITEABLECONST ON}
ScrollingText : string = 'This is right scrolling text ';
{$WRITEABLECONST OFF}
var
ScrollPosition: Integer;
begin
Label2.Caption := ScrollingText;
for ScrollPosition := (Length(ScrollingText) - 1) downto 2 do
begin
ScrollingText[ScrollPosition] := Label2.Caption[ScrollPosition - 1];
ScrollingText[1] := Label2.Caption[Length(ScrollingText) - 1];
end;
end;
But I suggest not using writeable const nor using the for loop at all:
procedure TForm1.FormCreate(Sender: TObject);
begin
...
Label2.Caption := 'This is right scrolling text ';
end;
procedure TForm1.Timer2Timer(Sender: TObject);
var
S: String;
begin
S := Label2.Caption;
S := S[Length(S)] + Copy(S, 1, Length(S) - 1);
Label2.Caption := S;
end;

Resources