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

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.

Related

onMouseMove override keeps onMouseUp from working

I have a TreeViewItem which its onMouseUp is not fired, I tried shrinking my complicated class and I was able to produce a working example of a onMouseUp not working, it seems the onMouseMove override is causing this behavior which is a mystery because I am using onMouseUp and I'm not overriding the onMouseMove!
How can I fix this code?
unit Unit2;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts,
FMX.TreeView;
type
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
procedure onItemMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.fmx}
procedure TForm2.FormCreate(Sender: TObject);
var
treeView: TTreeView;
treeViewItem: TTreeViewItem;
begin
treeView := TTreeView.Create(nil);
treeView.Position.X := 0;
treeView.Position.Y := 0;
treeView.Width := 200;
treeView.Height := 300;
treeView.Parent := form2;
treeViewItem := TTreeViewItem.Create(nil);
treeViewItem.Parent := treeView;
treeViewItem.Text := 'This is a test';
treeViewItem.OnMouseUp := onItemMouseUp;
end;
procedure TForm2.onItemMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single);
begin
ShowMessage('onItemMouseUp');
end;
procedure TForm2.MouseMove(Shift: TShiftState; X: Single; Y: Single);
begin
end;
end.
MouseMove(...) override; overrides every other onMouseMove, this is usually used if you need to ensure execution on MouseMove no matter what kind of object you are focusing, since you are overriding MoveMove you have to use the keyword Inherited inside the body which will ensure all the other onMouseMoves that are inherited work as well.
So you simply need to change your MouseMove to this:
procedure TForm2.MouseMove(Shift: TShiftState; X: Single; Y: Single);
begin
Inherited;
end;

How can I let a user move or drag a button on a form?

I have a form where I have created a button programmatically 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.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
FTableButton : TButton;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(FTableButton) then begin
FTableButton := TButton.Create(self);
FTableButton.Parent := self;
end;
end;
end.
How can I let the user move FTableButton on the form by dragging it?
By implementing the OnMouseDown, OnMouseMove and OnMouseUp events of a control you can allow the user to move it 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.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
FTableButton : TButton;
FTableButtonDragging : boolean;
FMouseDownLocation : TPoint;
FButtonStartingLocation : TPoint;
procedure TableButtonMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TableButtonMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure TableButtonMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(FTableButton) then begin
FTableButton := TButton.Create(self);
FTableButton.Parent := self;
FTableButton.Caption := 'I am New';
FTableButton.OnMouseDown := TableButtonMouseDown;
FTableButton.OnMouseMove := TableButtonMouseMove;
FTableButton.OnMouseUp := TableButtonMouseUp;
end;
end;
procedure TForm1.TableButtonMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FTableButtonDragging := true;
FMouseDownLocation := Mouse.CursorPos;
FButtonStartingLocation := TPoint.Create(FTableButton.Left, FTableButton.Top);
end;
procedure TForm1.TableButtonMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FTableButtonDragging then begin
FTableButton.Left := FButtonStartingLocation.X + (Mouse.CursorPos.X - FMouseDownLocation.X);
FTableButton.Top := FButtonStartingLocation.Y + (Mouse.CursorPos.Y - FMouseDownLocation.Y);
FTableButton.Invalidate;
end;
end;
procedure TForm1.TableButtonMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FTableButtonDragging := false;
end;
end.
Here we've added three new procedures to the form :
procedure TableButtonMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TableButtonMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
procedure TableButtonMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
and we have assigned these procedures as handlers for the new FTableButton's events :
FTableButton.OnMouseDown := TableButtonMouseDown;
FTableButton.OnMouseMove := TableButtonMouseMove;
FTableButton.OnMouseUp := TableButtonMouseUp;
When clicking on the button you need to store both the control's location and the mouse position when you placed the click, as well as that the mouse is currently down. Three new fields are used for this :
FTableButtonDragging : boolean;
FMouseDownLocation : TPoint;
FButtonStartingLocation : TPoint;
When moving the mouse, then, you can update the position of the control based on its original position and the difference between the current mouse position and the mouse position when the click was made.

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

Draw Rectangle on transparent form is very slow

AlphaBlend and DoubleBuffered set to True. I have Duo Core 2Ghz and drawing takes 100% CPU, even i had once BSOD. My goal is selecting custom area on screen and get coordinates. Enabling/disablin Windows Aero doesnt speed up. Thanks for help.
unit ZaznaczenieObszaru;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls;
type
TForm3 = class(TForm)
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FormKeyPress(Sender: TObject; var Key: Char);
private
public
{ Public declarations }
end;
var
Form3: TForm3;
rysuj: boolean;
poczatekX, poczatekY, xGlobalne, yGlobalne: Integer;
kolorIzy: TColor;
implementation
{$R *.dfm}
procedure TForm3.FormCreate(Sender: TObject);
begin
Width := Screen.Width;
Height := Screen.Height;
rysuj := False;
kolorIzy := 14413224;
end;
procedure TForm3.FormKeyPress(Sender: TObject; var Key: Char);
begin
if (Key = #13) then Close;
end;
procedure TForm3.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Image1.Picture.Bitmap := nil;
Image1.Canvas.Brush.Color := kolorIzy;
poczatekX := X;
poczatekY := Y;
rysuj := true;
end;
procedure TForm3.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if rysuj = true then
begin
xGlobalne := X;
yGlobalne := Y;
Image1.Picture.Bitmap := nil;
Image1.Canvas.Brush.Color := kolorIzy;
Image1.Canvas.Rectangle(poczatekX, poczatekY, xGlobalne, yGlobalne)
end;
end;
procedure TForm3.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
rysuj := False;
end;
end.
You could use a TPaintBox instead of TImage (It's Canvas is not meant for such usage as #Ken already commented) and draw your rectangle on the TPaintBox.OnPaint event. don't draw on Mouse events, but rather use TPaintBox.Invalidate. Here is an example:
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
poczatekX := X;
poczatekY := Y;
rysuj := True;
end;
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if rysuj then
begin
xGlobalne := X;
yGlobalne := Y;
PaintBox1.Invalidate;
end;
end;
procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
rysuj := False;
PaintBox1.Invalidate;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
if rysuj then
begin
PaintBox1.Canvas.Brush.Color := kolorIzy;
PaintBox1.Canvas.Rectangle(poczatekX, poczatekY, xGlobalne, yGlobalne);
end;
end;
I guess the same could be applied using only the TForm itself without any graphic controls, by drawing to the Form's canvas directly (same events as with the TPaintBox).
Try my NLDXPSelection component which is a non-visual component that provides drawing blue alpha blended selections on any control, form or screen. It has properties OnResize and OnFinish that tell the selection coördinates.
Source can be found here (open source).

User moving Shape at run time

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.

Resources