User moving Shape at run time - delphi

I have a unit called MachineShapes, with a type TShape on it. I am trying to get it so when a user clicks on shape they can move it. I think iam close but got a little confused. Thanks for any help
MachineShapes
unit MachineShape;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, extctrls,myDataModule,Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TMachine = class(TShape)
private
{ Private declarations }
FOnMouseDown : TNotifyEvent;
FOnMouseUp: TNotifyEvent;
FonMouseMove: TNotifyEvent;
procedure ControlMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
procedure ControlMouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: Integer);
procedure ControlMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
private
inReposition : boolean;
oldPos : TPoint;
Protected
procedure DoMouseDown; virtual;
procedure DoMouseUp; Virtual;
procedure DoMouseMove; virtual;
Published
property OnMouseDown: TNotifyEvent Read FOnMouseDown Write fOnMouseDown;
property OnMouseMove: TNotifyEvent Read FOnMouseMove write fOnMouseMove;
Property onMouseUp : TNotifyEvent Read FOnMouseUp write FOnMouseUp;
public
{ Public declarations }
end;
implementation
uses
deptlayout;
procedure TMachine.ControlMouseMove(Sender: TObject; Shift: TShiftState; X: Integer; Y: Integer);
const
minWidth = 20;
minHeight = 20;
var
newPos: TPoint;
frmPoint : TPoint;
begin
if inReposition then
begin
with TWinControl(Sender) do
begin
GetCursorPos(newPos);
Screen.Cursor := crSize;
Left := Left - oldPos.X + newPos.X;
Top := Top - oldPos.Y + newPos.Y;
oldPos := newPos;
end;
end;
end;
procedure TMachine.ControlMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer);
begin
if inReposition then
begin
Screen.Cursor := crDefault;
ReleaseCapture;
inReposition := False;
end;
end;
procedure TMachine.ControlMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer);
begin
inReposition:=True;
SetCapture(TWinControl(Sender).Handle);
GetCursorPos(oldPos);
end;
procedure tmachine.DoMouseDown;
begin
if assigned(fonmousedown) then
fonmousedown(self);
end;
procedure tmachine.DoMouseUp;
begin
if assigned(fonmouseup) then
fonmouseup(self);
end;
procedure tmachine.domousemove;
begin
if assigned(fonmousemove) then
fonmousemove(self);
end;
end.
How i call it..
procedure TFGetZoneDept.CreateShape(Sender: TObject);
var
machine : TMachine;
begin
//creates the shape
machine := MachineShape.TMachine.Create(fdeptlayout); //form to create shape on
machine.Parent := fdeptlayout; //form to add shape to
machine.OnMouseDown := machinemouseDown;
machine.OnMouseUp := machinemouseUp;
machine.OnMouseMove:= machinemouseMove;
end;
procedure TFGetZoneDept.MachineMouseDown(Sender: TObject);
var
machine: TMachine;
begin
machine := Sender as TMachine;
end;
procedure TFGetZoneDept.MachineMouseUp(Sender: TObject);
var
machine: TMachine;
begin
machine := Sender as TMachine;
end;
procedure TFGetZoneDept.machineMouseMove(Sender: TObject);
var
machine: TMachine;
begin
machine := sender as Tmachine;
end;

A shape is no Wincontrol and has no handle you could do something tike that....
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMachine=Class(TShape)
private
FX,FY:Integer;
Procedure MyMouseDown(var msg:TWMLButtonDown);message WM_LButtonDown;
Procedure MyMouseMove(var msg:TWMMouseMove);message WM_MouseMove;
End;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
FX,FY:Integer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TMachine }
procedure TMachine.MyMouseDown(var msg: TWMLButtonDown);
begin
inherited;
FX := msg.XPos;
FY := msg.YPos;
end;
procedure TMachine.MyMouseMove(var msg: TWMMouseMove);
begin
inherited;
if ssLeft in KeysToShiftState(msg.Keys) then
begin
Left := Left+ msg.XPos -FX;
Top := Top + msg.YPos -FY;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
With TMachine.Create(self) do
begin
Parent := Self;
Width := 200;
Height := 200;
end;
end;
end.

Related

How to draw freehand on TPaintBox (or any other control)?

I am trying to make a signature pad with Delphi 10.3 FMX. My understanding is that I should handle the OnMouseMove event, first setting coordinate in the OnMouseDown event, and then use the DrawLine() method.
So far I managed this:
unit HeaderFooterFormwithNavigation;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Graphics, FMX.Forms, FMX.Dialogs, FMX.TabControl,
System.Actions, FMX.ActnList, FMX.Objects, FMX.StdCtrls,
FMX.Controls.Presentation, FMX.Edit;
type
THeaderFooterwithNavigation = class(TForm)
ActionList1: TActionList;
PreviousTabAction1: TPreviousTabAction;
TitleAction: TControlAction;
NextTabAction1: TNextTabAction;
TopToolBar: TToolBar;
btnBack: TSpeedButton;
ToolBarLabel: TLabel;
btnNext: TSpeedButton;
TabControl1: TTabControl;
TabItem1: TTabItem;
TabItem2: TTabItem;
BottomToolBar: TToolBar;
pb1: TPaintBox;
edt1: TEdit;
edt2: TEdit;
edt3: TEdit;
procedure FormCreate(Sender: TObject);
procedure TitleActionUpdate(Sender: TObject);
procedure FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
procedure pb1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
procedure pb1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
private
{ Private declarations }
public
{ Public declarations }
end;
var
HeaderFooterwithNavigation: THeaderFooterwithNavigation;
_lastPoint: TPointF;
implementation
{$R *.fmx}
{$R *.LgXhdpiPh.fmx ANDROID}
{$R *.iPhone4in.fmx IOS}
procedure THeaderFooterwithNavigation.TitleActionUpdate(Sender: TObject);
begin
if Sender is TCustomAction then
begin
if TabControl1.ActiveTab <> nil then
TCustomAction(Sender).Text := TabControl1.ActiveTab.Text
else
TCustomAction(Sender).Text := '';
end;
end;
procedure THeaderFooterwithNavigation.FormCreate(Sender: TObject);
begin
{ This defines the default active tab at runtime }
TabControl1.First(TTabTransition.None);
end;
procedure THeaderFooterwithNavigation.FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
if (Key = vkHardwareBack) and (TabControl1.TabIndex <> 0) then
begin
TabControl1.First;
Key := 0;
end;
end;
procedure THeaderFooterwithNavigation.pb1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
_lastPoint.X := X;
_lastPoint.Y := Y;
end;
procedure THeaderFooterwithNavigation.pb1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
var
thisPoint: TPointF;
brush: TStrokeBrush;
begin
if pb1.Canvas.BeginScene then
try
pb1.Canvas.Stroke.Thickness := 2;
pb1.Canvas.Stroke.Kind := TBrushKind.Solid;
pb1.Canvas.Stroke.Color := TAlphaColors.Black;
thisPoint.X := X;
thisPoint.Y := Y;
pb1.Canvas.DrawLine(_lastPoint, thisPoint, 1);
_lastPoint := thisPoint;
finally
pb1.Canvas.EndScene;
end;
end;
end.
When I run it on my mobile (Android) and press on its screen, the whole screen becomes black. Why is that? How can I make simple freehand drawing app?
I've listened to Xylem's advice and switched to TImage control like this:
unit HeaderFooterFormwithNavigation;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Graphics, FMX.Forms, FMX.Dialogs, FMX.TabControl,
System.Actions, FMX.ActnList, FMX.Objects, FMX.StdCtrls,
FMX.Controls.Presentation, FMX.Edit;
type
THeaderFooterwithNavigation = class(TForm)
ActionList1: TActionList;
PreviousTabAction1: TPreviousTabAction;
TitleAction: TControlAction;
NextTabAction1: TNextTabAction;
TopToolBar: TToolBar;
btnBack: TSpeedButton;
ToolBarLabel: TLabel;
btnNext: TSpeedButton;
TabControl1: TTabControl;
TabItem1: TTabItem;
TabItem2: TTabItem;
BottomToolBar: TToolBar;
img1: TImage;
btnClear: TButton;
procedure FormCreate(Sender: TObject);
procedure TitleActionUpdate(Sender: TObject);
procedure FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
procedure img1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
procedure img1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Single);
procedure img1Tap(Sender: TObject; const Point: TPointF);
procedure img1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Single);
procedure btnClearClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
HeaderFooterwithNavigation: THeaderFooterwithNavigation;
_lastPoint: TPointF;
_down: Boolean;
implementation
{$R *.fmx}
{$R *.LgXhdpiPh.fmx ANDROID}
{$R *.iPhone4in.fmx IOS}
procedure THeaderFooterwithNavigation.TitleActionUpdate(Sender: TObject);
begin
if Sender is TCustomAction then
begin
if TabControl1.ActiveTab <> nil then
TCustomAction(Sender).Text := TabControl1.ActiveTab.Text
else
TCustomAction(Sender).Text := '';
end;
end;
procedure THeaderFooterwithNavigation.btnClearClick(Sender: TObject);
begin
img1.Bitmap.Clear(TAlphaColorRec.White);
end;
procedure THeaderFooterwithNavigation.FormCreate(Sender: TObject);
begin
{ This defines the default active tab at runtime }
img1.Bitmap := TBitmap.Create(round(img1.Width), round(img1.Height));
img1.Bitmap.Clear(TAlphaColorRec.White);
TabControl1.First(TTabTransition.None);
end;
procedure THeaderFooterwithNavigation.FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
if (Key = vkHardwareBack) and (TabControl1.TabIndex <> 0) then
begin
TabControl1.First;
Key := 0;
end;
end;
procedure THeaderFooterwithNavigation.img1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
_lastPoint.X := X;
_lastPoint.Y := Y;
_down:=True;
end;
procedure THeaderFooterwithNavigation.img1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Single);
var
thisPoint: TPointF;
begin
if _down then
begin
thisPoint.X := X;
thisPoint.Y := Y;
with img1.Bitmap.Canvas do
begin
BeginScene;
Stroke.Thickness := 5;
Stroke.Kind := TBrushKind.Solid;
Stroke.Color := TAlphaColors.Black;
DrawLine(_lastPoint, thisPoint, 1);
EndScene;
end;
_lastPoint := thisPoint;
end;
end;
procedure THeaderFooterwithNavigation.img1MouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
_down:=false;
end;
procedure THeaderFooterwithNavigation.img1Tap(Sender: TObject;
const Point: TPointF);
begin
_down:=True;
_lastPoint := Point;
end;
end.

Can Firemonkey TTabControl replicate VCL TPageControl.OnChanging event?

I'm Running Delphi Dx Seattle
In Delphi VCL's TPageControl there is a onChanging event where you could stop the page control from changing tab's
procedure TForm1.pgc1Changing(Sender: TObject; var AllowChange: Boolean);
begin
if MessageDlg('do you want to change tab?', mtConfirmation, [mbyes, mbno], 0, mbNo) = mrno then
AllowChange := false;
end;
Is there a way for Delphi Firemonkey TTabControl to replicate this?
e.g.if you have two tabs and clicking on the other tab pops up a question 'do you want to change tab?'
if you click No nothing happens click yes then it changes
This is the code i ended up using - it works with windows and android haven't tested with IOS
Ended up having to override some of the components procedures
TTabItem = class(FMX.TabControl.TTabItem)
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
end;
TTabControl = class(FMX.TabControl.TTabControl)
function GetTabIndex : integer;
public
procedure SetTabIndexv2(const Value: Integer);
property TabIndex: Integer read GetTabIndex write SetTabIndexv2 default -1;
end;
Here is an example of the full code
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.TabControl,
FMX.Controls.Presentation, FMX.StdCtrls;
type
TTabItem = class(FMX.TabControl.TTabItem)
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
end;
TTabControl = class(FMX.TabControl.TTabControl)
function GetTabIndex : integer;
public
procedure SetTabIndexv2(const Value: Integer);
property TabIndex: Integer read GetTabIndex write SetTabIndexv2 default -1;
end;
TForm1 = class(TForm)
tbc1: TTabControl;
tbtm1: TTabItem;
tbtm2: TTabItem;
btn1: TButton;
lblTab1: TLabel;
lblTab2: TLabel;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
procedure TTabItem.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Single);
begin
if (self.TabControl.ActiveTab <> self) and
((Button = TMouseButton.mbLeft) or (ssDouble in Shift)) then begin
MessageDlg('[Tab Item] do you want to do this?', System.UITypes.TMsgDlgType.mtInformation,
[System.UITypes.TMsgDlgBtn.mbYes, System.UITypes.TMsgDlgBtn.mbNo], 0, procedure (const AResult: TModalResult)
begin
begin
case AResult of
mrYes: self.TabControl.ActiveTab := self;
mrNo:;
end;
end;
end);
end else begin
inherited;
end;
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
if tbc1.TabIndex = 0 then
tbc1.TabIndex := 1
else
tbc1.TabIndex := 0;
end;
{ TTabControl }
function TTabControl.GetTabIndex: integer;
begin
result := FMX.TabControl.TTabControl(Self).TabIndex;
end;
procedure TTabControl.SetTabIndexv2(const Value: Integer);
begin
if self.TabIndex <> value then begin
MessageDlg('[tabcontrol] do you want to do this?', System.UITypes.TMsgDlgType.mtInformation,
[System.UITypes.TMsgDlgBtn.mbYes, System.UITypes.TMsgDlgBtn.mbNo], 0, procedure (const AResult: TModalResult)
begin
begin
case AResult of
mrYes: begin
FMX.TabControl.TTabControl(Self).TabIndex := value;
end;
mrNo : ;
end;
end;
end);
end;
end;
end.
if you can see any way to improve it please let me know

Moving images while drag and drop

I have an TImage on a TPanel, and an other (empty) TPanels. I want to drag
the image from the first to the second panel using the drag and drop.
I actually want to see the image while it's moving from one panel to the
other (semi-transparent).
I think I should use TDragObject.GetDragImages but I can't figure out how to construct the whole magic.
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Image1.ControlStyle := Image1.ControlStyle + [csDisplayDragImage]; // ???
TImage(Sender).BeginDrag(False);
end;
procedure TForm1.Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
// ???
end;
procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Source is TImage) then
Accept := TImage(Source).Parent <> Sender;
end;
procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if (Source is TImage) then
begin
TImage(Source).Parent := TPanel(Sender);
TImage(Source).Align := alClient;
end;
end;
Update - I found a useful article: Implementing Professional Drag & Drop In VCL/CLX Applications
unit Unit3;
interface
// 2012 Thomas Wassermann - demo
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMyDragObject = class(TDragControlObject)
private
FImageList:TImageList;
FDragSource:TControl;
protected
function GetDragImages: TDragImageList; override;
public
Procedure StartDrag(G:TGraphic;p:TPoint;DragSource:TControl);
Constructor Create(AControl: TControl); override;
Destructor Destroy;override;
Property DragSource:TControl read FDragSource;
end;
TForm3 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Image1: TImage;
procedure Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure FormCreate(Sender: TObject);
procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure FormDestroy(Sender: TObject);
procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private-Deklarationen }
FDragObject:TMyDragObject;
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
constructor TMyDragObject.Create(AControl: TControl);
begin
inherited;
FImageList:=TImageList.Create(nil);
end;
destructor TMyDragObject.Destroy;
begin
FImageList.Free;
inherited;
end;
function TMyDragObject.GetDragImages: TDragImageList;
begin
Result := FImageList;
end;
{$R *.dfm}
procedure TMyDragObject.StartDrag(G: TGraphic;p:TPoint;DragSource:TControl);
var
bmp:TBitMap;
begin
FDragSource := DragSource;
bmp:=TBitMap.Create;
try
FImageList.Width := g.Width;
FImageList.Height := g.Height;
bmp.Width := g.Width;
bmp.Height := g.Height;
bmp.Canvas.Draw(0,0,g);
FImageList.Add(bmp,nil);
finally
bmp.Free;
end;
FImageList.SetDragImage(0,p.x,p.y)
end;
procedure TForm3.FormCreate(Sender: TObject);
var
i:Integer;
begin
ControlStyle := ControlStyle + [csDisplayDragImage];
for I := 0 to ControlCount -1 do
if Controls[i] is TPanel then
TPanel(Controls[i]).ControlStyle := TPanel(Controls[i]).ControlStyle + [csDisplayDragImage];
ReportMemoryLeaksOnShutDown := True;
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
if Assigned(FDragObject) then FDragObject.Free;
end;
procedure TForm3.Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
var
p:TPoint;
begin
p:=TImage(Sender).ScreenToClient(mouse.cursorpos);
if Assigned(FDragObject) then FDragObject.Free;
FDragObject := TMyDragObject.Create(TImage(Sender));
FDragObject.StartDrag(TImage(Sender).Picture.Graphic,p,TImage(Sender));
DragObject := FDragObject;
end;
procedure TForm3.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if FDragObject.DragSource is TImage then
TImage(FDragObject.DragSource).Parent := TPanel(Sender);
end;
procedure TForm3.Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := Source is TMyDragObject;
end;
end.

How to add more objects to my form without adding the same amount of code

I have been making a small game for fun. In the game you are a small spaceship(an image) that shoots lazer beams(shape) at an object(panel). At this moment u can only fire one lazer beam at a time because there is only one lazer beam(shape) and there is only one object(panel) to shoot. So with the coding I have I would like to know how I can add more lazer beams and objects but especially lazer beams because I don't want to repeat the procedures for each lazer beam and for each panel.
Here is the code.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, jpeg;
type
TForm1 = class(TForm)
Panel1: TPanel;
Timer1: TTimer;
Timer2: TTimer;
Button1: TButton;
Shape1: TShape;
Timer3: TTimer;
Image1: TImage;
procedure Timer2Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure Timer3Timer(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
procedure StartPanelAnimation1;
procedure DoPanelAnimationStep1;
function PanelAnimationComplete1: Boolean;
procedure Startlazeranimation1;
procedure DolazeranimationStep1;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
var key : char;
{$R *.dfm}
{ TForm1 }
{ TForm1 }
procedure TForm1.DoPanelAnimationStep1;
begin
Panel1.Top := Panel1.Top+1;
end;
function TForm1.PanelAnimationComplete1: Boolean;
begin
Result := Panel1.Top=512;
end;
procedure TForm1.StartPanelAnimation1;
begin
Panel1.Top := 0;
Timer1.Interval := 1;
Timer1.Enabled := True;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
DoPanelAnimationStep1;
if PanelAnimationComplete1 then
StartPanelAnimation1;
if (shape1.Top < panel1.Top) and (shape1.Left < panel1.Left+104) and (shape1.Left > panel1.Left) then
begin
startpanelanimation1;
sleep(10);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
button1.Hide;
key := 'a';
timer2.Enabled := true;
StartPanelAnimation1;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
shape1.Visible := false;
timer3.Enabled := false;
timer2.Enabled := false;
end;
procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
image1.Left := image1.Left-10;
end;
procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
image1.Left := image1.Left+10;
end;
procedure TForm1.DolazeranimationStep1;
begin
shape1.Top := shape1.Top-10;
end;
procedure TForm1.Startlazeranimation1;
begin
shape1.Top := image1.Top;
shape1.Left := image1.Left+55;
shape1.Visible := true;
Timer3.Interval := 1;
Timer3.Enabled := True;
end;
procedure TForm1.Timer3Timer(Sender: TObject);
var k : integer;
begin
DolazeranimationStep1;
if (shape1.Top < panel1.Top) and (shape1.Left < panel1.Left+104) and (shape1.Left > panel1.Left) or (shape1.Top=clientheight) then
begin
timer3.Enabled := false;
shape1.Visible := false;
for k := 1 to 5 do
sleep(1);
begin
application.ProcessMessages;
end;
shape1.Top := 0;
shape1.Left := 0;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
shape1.Show;
startlazeranimation1;
end;
end.
(The above is the old code)
I have successfully done what Stijn Sanders suggested. But now in this if
if (Shape1.top < panel1.Top) and (shape1.Left < panel1.Left+104) and (shape1.Left > panel1.Left) then
never tests true because shape1 never passes panel1 it, only the shape created on on click passes the panel.
So is there another way to test if the shape is at the pnael.
Not all components need to be created at design time. At run-time, for example using a TTimer and its event, you can call TShape.Create(Self); to have an extra shape. Keep the reference to the resulting value somewhere convenient, for example a (dynamic) array, and remember to set MyShape.Parent:=Self; or MyShape.Parent:=Panel1; so the system knows when and where to display this new control.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
const
MaxRays=100;
RayStep=8;
type
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Rays:array[0..MaxRays-1] of TShape;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
i:integer;
begin
for i:=0 to MaxRays-1 do Rays[i]:=nil;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
i:integer;
begin
i:=0;
while (i<MaxRays) and (Rays[i]<>nil) do inc(i);
if i<MaxRays then
begin
Rays[i]:=TShape.Create(Self);
Rays[i].Shape:=stEllipse;
Rays[i].Pen.Color:=clRed;
Rays[i].Pen.Style:=psSolid;
Rays[i].Brush.Color:=clYellow;
Rays[i].Brush.Style:=bsSolid;
Rays[i].SetBounds(X-4,Y-20,9,41);
Rays[i].Parent:=Self;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i:integer;
begin
for i:=0 to MaxRays-1 do
if Rays[i]<>nil then
begin
Rays[i].Top:=Rays[i].Top-RayStep;
if Rays[i].Top<0 then FreeAndNil(Rays[i]);
end;
end;
end.
Create your objects dynamically at runtime and keep track of them in a list, then you can loop through the list when needed, eg:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, jpeg;
type
TForm1 = class(TForm)
PanelTimer: TTimer;
Button1: TButton;
LazerTimer: TTimer;
Image1: TImage;
procedure PanelTimerTimer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure LazerTimerTimer(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Lazers: TList;
Panels: TList;
procedure StartPanelAnimation;
procedure StartLazerAnimation;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.StartPanelAnimation;
var
Panel: TPanel;
begin
Panel := TPanel.Create(Self);
Panel.Parent := Self;
Panel.Top := 0;
// set other Panel properties as needed...
Panel.Visible := True;
Panels.Add(Panel);
if not PanelTimer.Enabled then
begin
PanelTimer.Interval := 1;
PanelTimer.Enabled := True;
end;
end;
procedure TForm1.PanelTimerTimer(Sender: TObject);
var
k: Integer;
Panel: TPanel;
begin
for k := 0 to Panels.Count-1 do
begin
Panel := TPanel(Panels[k]);
Panel.Top := Panel.Top + 1;
if Panel.Top = 512 then
Panel.Top := 0;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StartPanelAnimation1;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Lazers := TList.Create;
Panels := TList.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Lazers.Free;
Panels.Free;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
PanelTimer.Enabled := False;
LazerTimer.Enabled := False;
end;
procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
Image1.Left := Image1.Left - 10;
end;
procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
Image1.Left := Image1.Left + 10;
end;
procedure TForm1.StartLazerAnimation;
var
Lazer: TShape;
begin
Lazer := TShape.Create(Self);
Lazer.Parent := Self;
// set Lazer properties as needed...
Lazer.Top := Image1.Top;
Lazer.Left := Image1.Left + 55;
Lazer.Visible := True;
Lazers.Add(Lazer);
if not Lazer.Enabled then
begin
Lazer.Interval := 1;
Lazer.Enabled := True;
end;
end;
procedure TForm1.LazerTimerTimer(Sender: TObject);
var
k, m : integer;
Lazer: TShape;
Panel: TPanel;
PanelHit: Boolean;
begin
k := 0;
while k < Lazers.Count do
begin
Lazer := TShape(Lazers[k]);
Lazer.Top := Lazer.Top - 10;
for m := 0 to Panels.Count-1 do
begin
Panel := TPanel(Panels[m]);
PanelHit := (Lazer.Top > (Panel.Top+Panel.Height)) and (Lazer.Left > Panel.Left) and (Lazer.Left < (Panel.Left+Panel.Width));
if PanelHit then
begin
Panels.Remove(Panel);
Panel.Free;
if Panels.Count = 0 then
PanelTimer.Enabled := False;
Break;
end;
end;
if PanelHit or (Lazer.Top = 0) then
begin
Lazers.Remove(Lazer);
Lazer.Free;
if Lazers.Count = 0 then
LazerTimer.Enabled := False;
end else
Inc(k);
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
StartLazerAnimation;
end;
end.

Drop down menu for TButton

I am trying to simulate a drop down menu for a TButton, as shown below:
procedure DropMenuDown(Control: TControl; PopupMenu: TPopupMenu);
var
APoint: TPoint;
begin
APoint := Control.ClientToScreen(Point(0, Control.ClientHeight));
PopupMenu.Popup(APoint.X, APoint.Y);
end;
procedure TForm1.Button1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
DropMenuDown(Button1, PopupMenu1);
// ReleaseCapture;
end;
end;
The problem is that when the menu is dropped down, if I click the button again I would like the menu to close, but instead it drops down again.
I am looking for a solution specifically for generic Delphi TButton not any 3rd Party equivalent.
After reviewing the solution provided by Whiler & Vlad, and comparing it to the way WinSCP implements the same thing, I'm currently using the following code:
unit ButtonMenus;
interface
uses
Vcl.Controls, Vcl.Menus;
procedure ButtonMenu(Control: TControl; PopupMenu: TPopupMenu);
implementation
uses
System.Classes, WinApi.Windows;
var
LastClose: DWord;
LastPopupControl: TControl;
LastPopupMenu: TPopupMenu;
procedure ButtonMenu(Control: TControl; PopupMenu: TPopupMenu);
var
Pt: TPoint;
begin
if (Control = LastPopupControl) and (PopupMenu = LastPopupMenu) and (GetTickCount - LastClose < 100) then begin
LastPopupControl := nil;
LastPopupMenu := nil;
end else begin
PopupMenu.PopupComponent := Control;
Pt := Control.ClientToScreen(Point(0, Control.ClientHeight));
PopupMenu.Popup(Pt.X, Pt.Y);
{ Note: PopupMenu.Popup does not return until the menu is closed }
LastClose := GetTickCount;
LastPopupControl := Control;
LastPopupMenu := PopupMenu;
end;
end;
end.
It has the advantage of not requiring any code changes to the from, apart from calling ButtonMenu() in the onClick handler:
procedure TForm1.Button1Click(Sender: TObject);
begin
ButtonMenu(Button1, PopupMenu1);
end;
Following our (Vlad & I) discussion, you use a variable to know when the popup was last opened to choose if you display the popupmenu or cancel the mouse event:
unit Unit4;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.StdCtrls;
type
TForm4 = class(TForm)
PopupMenu1: TPopupMenu;
Button1: TButton;
fgddfg1: TMenuItem;
fdgdfg1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
cMenuClosed: Cardinal;
public
{ Public declarations }
end;
var
Form4: TForm4;
implementation
{$R *.dfm}
procedure DropMenuDown(Control: TControl; PopupMenu: TPopupMenu);
var
APoint: TPoint;
begin
APoint := Control.ClientToScreen(Point(0, Control.ClientHeight));
PopupMenu.Popup(APoint.X, APoint.Y);
end;
procedure TForm4.Button1Click(Sender: TObject);
begin
DropMenuDown(Button1, PopupMenu1);
cMenuClosed := GetTickCount;
end;
procedure TForm4.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) and not ((cMenuClosed + 100) < GetTickCount) then
begin
ReleaseCapture;
end;
end;
procedure TForm4.FormCreate(Sender: TObject);
begin
cMenuClosed := 0;
end;
end.

Resources