Delphi7, make a shape jump when pressing Up key - delphi

I'd like to make a shape jump when the player presses the UP key, so the best i could think of is this, but the method i used is terrible and problematic:
(shape coordinates: shape1.top:=432;)
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case key of
vk_up: shape1.top:=shape1.top-40 //so that it jumps to 392
end;
end;
And now this timer:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
timer1.interval:=300
if shape1.Top<400 then //if shape1.top=392 < 400
begin
shape1.Top:=432; //move back to 432
end;
end;
The problem is that players can constantly press the key UP, which I don't want. I know this method is terrible, so i hope you have something better than this and i would be grateful if you could share it with me.

Here's a ball bouncing in a constant force field (e.g., the field of gravity close to the surface of the Earth). The lateral walls and the floor are bouncing surfaces. You can add additional forces using the arrow keys:
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TRealVect = record
X, Y: real;
end;
const
ZeroVect: TRealVect = (X: 0; Y: 0);
type
TForm5 = class(TForm)
Timer1: TTimer;
procedure FormPaint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
private
{ Private declarations }
function ACC: TRealVect;
const
RADIUS = 16;
DAMPING = 0.8;
DT = 0.2;
GRAVITY: TRealVect = (X: 0; Y: 10);
var
FForce: TRealVect;
FPos: TRealVect;
FVel: TRealVect;
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
function RealVect(X, Y: real): TRealVect;
begin
result.X := X;
result.Y := Y;
end;
function Add(A, B: TRealVect): TRealVect;
begin
result.X := A.X + B.X;
result.Y := A.Y + B.Y;
end;
function Scale(A: TRealVect; C: real): TRealVect;
begin
result.X := C*A.X;
result.Y := C*A.Y;
end;
function TForm5.ACC: TRealVect;
begin
result := Add(GRAVITY, FForce);
end;
procedure TForm5.FormCreate(Sender: TObject);
begin
FPos := RealVect(Width div 2, 10);
FVel := RealVect(0, 0);
end;
procedure TForm5.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_UP:
FForce := RealVect(0, -20);
VK_DOWN:
FForce := RealVect(0, 10);
VK_RIGHT:
FForce := RealVect(10, 0);
VK_LEFT:
FForce := RealVect(-10, 0);
end;
end;
procedure TForm5.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
FForce := ZeroVect;
end;
procedure TForm5.FormPaint(Sender: TObject);
begin
Canvas.Brush.Color := clRed;
Canvas.Ellipse(round(FPos.X - RADIUS), round(FPos.Y - RADIUS),
round(FPos.X + RADIUS), round(FPos.Y + RADIUS));
end;
procedure TForm5.Timer1Timer(Sender: TObject);
begin
FVel := Add(FVel, Scale(ACC, DT));
FPos := Add(FPos, Scale(FVel, DT));
if FPos.Y + RADIUS >= ClientHeight then
begin
FVel.Y := -DAMPING*FVel.Y;
FPos.Y := ClientHeight - RADIUS - 1;
end;
if FPos.X - RADIUS <= 0 then
begin
FVel.X := -DAMPING*FVel.X;
FPos.X := RADIUS + 1;
end;
if FPos.X + RADIUS >= ClientWidth then
begin
FVel.X := -DAMPING*FVel.X;
FPos.X := ClientWidth - RADIUS - 1;
end;
Invalidate;
end;
end.
Set the timer's interval to 30, as 'usual'.
Compiled sample EXE

If the player can hold down a key and KeyDown fires repeatedly, you can lock it.
First, declare a field on the form called FKeyLock: set of byte. (Note: this technique will fail if you get any Key values higher than 255, but the ones you're likely to deal with won't be that high.)
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key in FKeyLock then
Exit;
case key of
vk_up:
begin
shape1.top:=shape1.top-40; //so that it jumps to 392
include(FKeyLock, vk_up);
end;
end;
end;
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
exclude(FKeyLock, key);
end;

Related

Delphi Graphics32 relative mouse position (to the layer)

I have a ImgView32, that is anchored to all form margins. The form is maximized.
The bitmap of ImgView is not fixed (it can be of different sizes)
I am trying to draw a line on a transparent layer using ther code from this question:Drawing lines on layer
Now the problem is that, using that exact code, I can only draw in the top-left corner, like in this image:
As you can observe, the lines can be drawn only in the left top corner.
If I try to add some value to the Start and End Points, the whole thing goes crazy. So I must find a way to translate the points in such a fashion that, the user will be able to draw only inside of the center rect (visible in the image)
I am out of ideas.
Please help
Here is the whole unit:
unit MainU;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,GR32, GR32_Image, GR32_Layers, GR32_Backends, GR32_PNG, StdCtrls,
ExtCtrls;
type
TForm5 = class(TForm)
ImgView: TImgView32;
Button1: TButton;
Memo: TMemo;
Edit3: TEdit;
Button2: TButton;
RadioGroup1: TRadioGroup;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
procedure ImgViewResize(Sender: TObject);
private
{ Private declarations }
FStartPoint, FEndPoint: TPoint;
FDrawingLine: boolean;
bm32: TBitmap32;
BL : TBitmapLayer;
FSelection: TPositionedLayer;
public
{ Public declarations }
procedure AddLineToLayer;
procedure AddCircleToLayer;
procedure SwapBuffers32;
procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
procedure LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
procedure SetSelection(Value: TPositionedLayer);
property Selection: TPositionedLayer read FSelection write SetSelection;
Procedure SelectGraficLayer(idu:string);
procedure AddTransparentPNGlayer;
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
var
imwidth: integer;
imheight: integer;
OffsX, OffsY: Integer;
const
penwidth = 3;
pencolor = clBlue; // Needs to be a VCL color!
procedure TForm5.AddLineToLayer;
begin
bm32.Canvas.Pen.Color := pencolor;
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
procedure TForm5.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
begin
imwidth := Form5.ImgView.Width;
imheight := Form5.ImgView.Height;
with ImgView.PaintStages[0]^ do
begin
if Stage = PST_CLEAR_BACKGND then Stage := PST_CUSTOM;
end;
bm32 := TBitmap32.Create;
bm32.DrawMode := dmTransparent;
bm32.SetSize(imwidth,imheight);
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.Pen.Color := pencolor;
with ImgView do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Scaled := True;
Bitmap.DrawMode := dmTransparent;
Bitmap.SetSize(imwidth, imheight);
Bitmap.Canvas.Pen.Width := 4;//penwidth;
Bitmap.Canvas.Pen.Color := clBlue;
Bitmap.Canvas.FrameRect(Rect(20, 20, imwidth-20, imheight-20));
Bitmap.Canvas.TextOut(15, 32, 'ImgView');
end;
AddTransparentPNGLayer;
BL := TBitmapLayer.Create(ImgView.Layers);
try
BL.Bitmap.DrawMode := dmTransparent;
BL.Bitmap.SetSize(imwidth,imheight);
BL.Bitmap.Canvas.Pen.Width := penwidth;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
BL.Scaled := False;
BL.OnMouseDown := LayerMouseDown;
BL.OnMouseUp := LayerMouseUp;
BL.OnMouseMove := LayerMouseMove;
BL.OnPaint := LayerOnPaint;
except
Edit3.Text:=IntToStr(BL.Index);
BL.Free;
raise;
end;
FDrawingLine := false;
SwapBuffers32;
end;
procedure TForm5.FormDestroy(Sender: TObject);
begin
bm32.Free;
BL.Free;
end;
procedure TForm5.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
const //0..1
Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
R: TRect;
I, J: Integer;
OddY: Integer;
TilesHorz, TilesVert: Integer;
TileX, TileY: Integer;
TileHeight, TileWidth: Integer;
begin
TileHeight := 13;
TileWidth := 13;
TilesHorz := Buffer.Width div TileWidth;
TilesVert := Buffer.Height div TileHeight;
TileY := 0;
for J := 0 to TilesVert do
begin
TileX := 0;
OddY := J and $1;
for I := 0 to TilesHorz do
begin
R.Left := TileX;
R.Top := TileY;
R.Right := TileX + TileWidth;
R.Bottom := TileY + TileHeight;
Buffer.FillRectS(R, Colors[I and $1 = OddY]);
Inc(TileX, TileWidth);
end;
Inc(TileY, TileHeight);
end;
end;
procedure TForm5.ImgViewResize(Sender: TObject);
begin
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X-OffsX, Y-OffsY);
FDrawingLine := true;
end;
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm5.SetSelection(Value: TPositionedLayer);
begin
if Value <> FSelection then
begin
FSelection := Value;
end;
end;
procedure TForm5.SwapBuffers32;
begin
TransparentBlt(
BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;
procedure TForm5.AddTransparentPNGlayer;
var
mypng:TPortableNetworkGraphic32;
B : TBitmapLayer;
P: TPoint;
W, H: Single;
begin
try
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromFile('C:\Location\Of\ATransparentPNGFile.png');
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
except
Free;
raise;
end;
Selection := B;
Edit3.Text:=IntToStr(B.Index);
finally
mypng.Free;
end;
end;
end.
What am I doing wrong? Please test the unit above to see what I mean. Remember to add a ImgView and anchor it to all margins, then at runtime, maximize the form and try to draw the lines...
EDIT
In the green image above, there is a rect, more like a square in the middle of it (not very visible) but you can see it if you look closely.
Since my problem might be misunderstood, please take a look at the following image
I need to be able to draw ONLY in the white rectangle (Bitmap) in the middle of the ImgView. I do not know how to explain better.
It is not a solution for me to make the rectangle/Bitmap fit exactly the ImgView, because that is not the point of my project.
Take a look at Paint.net and imagine that my project kind of does the same (except it's not that complex). But the principle is the same: you decide the size of your document/image when you start a new project, then you add different images as layers, you scale and rotate them, and now I want to allow the users to draw lines inside of a special layer (the drawing layer)
But everything happens inside the boundaries of that document size. Like for example in the above image, the size of the document there is A5 (100dpi) scaled at 83%.
So my problem is that I cannot allow the users to draw the lines outside the white rectangle (middle of the screen). So their lines can start in those boundaries and end there.
I know my test unit is not perfectly clean. I pasted some functions used in the main project and quickly removed some parts from them that are not relevant to this example. The AddTransparentPng procedure is there only to allow the testing of adding a transparent image to the ImgView so I can test if the drawing layer is not covering another possible latyer.
(The Scaled property belongs to the layer (B) it's under the 'with B' statement. I removed the With 'ImgView.Bitmap... Location' statement so it would not bother you anymore :) )
Anyway, please do not pay attention to the code that does not affect the drawing of lines. That code is what needs attention.
EDIT
If I set the layer's scaled to true (Scaled:=true) then it messes everything up, like in the image bellow:
I still have to use offsets but a little differently
Thank you
Error one
In LayerMouseMove() you subtract OffsX and OffsY from FStartPoint in BL.Bitmap.Canvas.MoveTo(). FStartPoint was already adjusted in LayerMouseDown(). I told you to "In the three Mouse procs adjust the X and Y arguments only to become X-OffsX and Y-OffsY." Note arguments only Here's LayerMouseMove() corrected:
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
// BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
Error two
I also told you to add if FDrawingLine then ... condition to LayerMouseUp() to avoid spurious line when the mouse down happens outside of the layer, but mouse up occurs inside. The corrected LayerMouseUp():
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
end;
Error three
The posted code does not perform as your first image shows. The image looks like you would have outcommented the line BL.Location := ... in ImgViewResize(). Possibly you did this because of Error one. Anyway, with ImgViewResize as follows and the other corrections above I get the result as shown in the picture that follows.
procedure TForm5.ImgViewResize(Sender: TObject);
begin
// centering the drawing area
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
Variables imwidth and imheight defines the size of the drawing area. If you change these you need to recalculate OffsX and OffsY and you need to resize the backbuffer bm32 as well.
The lines in the corners indicate the extent of the drawing area (defined by imwidth and imheight) in the middle of the window. It stays the same also when the window is maximized.
Ok, I solved it. Here is the final (relevant) code:
procedure TForm5.ImgViewResize(Sender: TObject);
begin
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
procedure TForm5.SwapBuffers32;
begin
TransparentBlt(
BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;
procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X-OffsX, Y-OffsY);
FDrawingLine := true;
end;
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm5.AddLineToLayer;
begin
bm32.Canvas.Pen.Color := pencolor;
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
With this code, everything works as expected. The drawing of lines can only happen within the boundaries
Thank you

OnStartDrag not being called on control (DragMode = dmManual)

Using: Delphi XE2 Update 4.1, 32-bit VCL application, Windows 8
If DragMode is set to dmAutomatic the the OnStartDrag event is called; however if the DragMode is set to dmManual, the OnStartDrag event is bypassed.
Is this by design? How to ensure that OnStartDrag event is called?
EDIT: Code posted on request. The event in question is TTableDesigner.LblStartDrag which is not being executed after a call to BeginDrag (in TTableDesigner.LblOnMouseDown) .
unit uTableDesigner;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Graphics, JvCaptionPanel,
StdCtrls, ExtCtrls;
type
TMyTable = record
TableName: String;
TableFields: TStrings;
TableObject: Pointer;
end;
PMyTable = ^TMyTable;
TTableDesigner = class(TCustomControl)
procedure CreateWnd; override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LblOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure LblDragDrop(Sender, Source: TObject; X, Y: Integer);
procedure LblDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure LblEndDrag(Sender, Target: TObject; X, Y: Integer);
procedure LblStartDrag(Sender: TObject; var DragObject: TDragObject);
// procedure Paint; override;
private
{ Private declarations }
FTableList: TList;
FCaptionPanelList: TList;
FPanelSlot_Left: Integer;
FPanelSlot_Top: Integer;
FStartDragPnl: TJvCaptionPanel;
FDragHoverPnl: TJvCaptionPanel;
FEndDragPnl: TJvCaptionPanel;
procedure HighlightPanelLabel(ALabel: TLabel);
protected
{ Protected declarations }
public
{ Public declarations }
procedure AddTable(const ATableName: String; const AFields: TStrings);
procedure DeleteTable(const ATableName: String);
procedure DeleteAllTables;
published
{ Published declarations }
property Align;
property Visible;
property Color;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TTableDesigner]);
end;
constructor TTableDesigner.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTableList := TList.Create;
FCaptionPanelList := TList.Create;
FPanelSlot_Left := 40;
FPanelSlot_Top := 40;
end;
destructor TTableDesigner.Destroy;
begin
DeleteAllTables;
FTableList.Free;
FCaptionPanelList.Free;
inherited;
end;
procedure TTableDesigner.CreateWnd;
begin
inherited;
end;
procedure TTableDesigner.AddTable(const ATableName: String; const AFields: TStrings);
var
pnl: TJvCaptionPanel;
c, h, j: Integer;
lbl: TLabel;
MyTable: PMyTable;
begin
pnl := TJvCaptionPanel.Create(Self);
pnl.Parent := Self;
pnl.Color := clWhite;
pnl.Caption := ATableName;
pnl.CaptionPosition := dpTop;
pnl.Left := FPanelSlot_Left;
pnl.Top := FPanelSlot_Top;
// FPanelSlot_Left := FPanelSlot_Left + pnl.Width + 40;
// if FPanelSlot_Left > ClientWidth - 100 then
// begin
// FPanelSlot_Left := 40;
//
// j := 0;
// for c := 0 to FTableList.Count - 1 do
// if j < TJvCaptionPanel(TMyTable(FTableList.Items[c]^).TableObject).Height then
// j := TJvCaptionPanel(TMyTable(FTableList.Items[c]^).TableObject).Height;
//
// FPanelSlot_Top := FPanelSlot_Top + j + 40;
// end;
h := 0;
for c := 0 to AFields.Count - 1 do
begin
lbl := TLabel.Create(pnl);
lbl.Parent := pnl;
lbl.Align := alTop;
lbl.Caption := AFields[c];
lbl.Transparent := False;
lbl.ParentColor := False;
lbl.DragKind := dkDrag;
lbl.OnMouseDown := LblOnMouseDown;
lbl.OnDragDrop := LblDragDrop;
lbl.OnDragOver := LblDragOver;
lbl.OnEndDrag := LblEndDrag;
lbl.OnStartDrag := LblStartDrag;
// lbl.DragMode := dmAutomatic;
h := h + lbl.Height + 4;
end;
pnl.ClientHeight := pnl.CaptionHeight + h;
MyTable := AllocMem(SizeOf(TMyTable));
Initialize(MyTable^);
MyTable.TableName := ATableName;
MyTable.TableFields := TStringList.Create;
MyTable.TableFields.Assign(AFields);
MyTable.TableObject := pnl;
FTableList.Add(MyTable);
end;
procedure TTableDesigner.DeleteTable(const ATableName: String);
var
c: Integer;
begin
for c := 0 to FTableList.Count - 1 do
if TMyTable(FTableList.Items[c]^).TableName = ATableName then
begin
TJvCaptionPanel(TMyTable(FTableList.Items[c]^).TableObject).Free;
TMyTable(FTableList.Items[c]^).TableFields.Free;
Finalize(TMyTable(FTableList.Items[c]^));
FreeMem(FTableList.Items[c]);
FTableList.Delete(c);
Break;
end;
end;
procedure TTableDesigner.DeleteAllTables;
var
c: Integer;
begin
for c := FTableList.Count - 1 downto 0 do
begin
TJvCaptionPanel(TMyTable(FTableList.Items[c]^).TableObject).Free;
TMyTable(FTableList.Items[c]^).TableFields.Free;
Finalize(TMyTable(FTableList.Items[c]^));
FreeMem(FTableList.Items[c]);
FTableList.Delete(c);
end;
end;
procedure TTableDesigner.HighlightPanelLabel(ALabel: TLabel);
var
pnl: TJvCaptionPanel;
c: Integer;
begin
pnl := TJvCaptionPanel(ALabel.Parent);
for c := 0 to pnl.ControlCount - 1 do
if pnl.Controls[c] = ALabel then
TLabel(pnl.Controls[c]).Color := clHighlight
else
TLabel(pnl.Controls[c]).Color := pnl.Color;
end;
procedure TTableDesigner.LblOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
HighlightPanelLabel(TLabel(Sender));
BeginDrag(False, 4);
end;
procedure TTableDesigner.LblDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
FEndDragPnl := TJvCaptionPanel(TLabel(Sender).Parent);
FEndDragPnl.Color := clWhite;
end;
procedure TTableDesigner.LblDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
FDragHoverPnl := TJvCaptionPanel(TLabel(Sender).Parent);
FDragHoverPnl.Color := clGreen;
Accept := True;
end;
procedure TTableDesigner.LblEndDrag(Sender, Target: TObject; X, Y: Integer);
begin
TJvCaptionPanel(TLabel(Sender).Parent).Color := clPurple;
end;
procedure TTableDesigner.LblStartDrag(Sender: TObject; var DragObject: TDragObject);
begin
FStartDragPnl := TJvCaptionPanel(TLabel(Sender).Parent);
FStartDragPnl.Color := clRed;
end;
// procedure TTableDesigner.Paint;
// var
// c: Integer;
// begin
// inherited;
//
// // Canvas.Pen.Mode := pmBlack;
// // Canvas.Pen.Color := clBlack;
// // Canvas.Pen.Style := psSolid;
// // Canvas.Pen.Width := 1;
// // Canvas.MoveTo(50, 50);
// // Canvas.LineTo(500, 500);
//
// end;
end.
You're in a method of 'TTableDesigner', if you do not qualify a method 'Self' is implied. So the 'BeginDrag' call applies to the TableDesigner object.
You'd rather call 'TLabel(Sender).BeginDrag(..'.

How can a control receive mouse events after the mouse is dragged beyond its borders?

I'm creating a custom control which recognizes when the mouse is dragging, specifically using messages WM_LBUTTONDOWN, WM_LBUTTONUP, and WM_MOUSEMOVE. When the mouse goes down, I capture the position on the control, and then when the mouse moves, if the left mouse button is down, I do more handling (calculating between starting and ending points).
The problem is, I'm expecting the mouse to go out of the control, and even out of the form, but when the mouse leaves the control, it no longer captures mouse events. Is there a way I can handle specifically the WM_MOUSEMOVE and WM_LBUTTONUP messages without the mouse being over the control?
You can use SetCapture/ReleaseCapture Windows API to continue to get mouse events when the cursor moves outside the control.
Releasecapture will work for Wincontrols, an other way could be a Mousehook. That's just a demo ....
unit MouseHook;
// 2012 by Thomas Wassermann
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm3 = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
var
HookHandle: Cardinal;
Type
tagMSLLHOOKSTRUCT = record
POINT: TPoint;
mouseData: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: DWORD;
end;
TMSLLHOOKSTRUCT = tagMSLLHOOKSTRUCT;
PMSLLHOOKSTRUCT = ^TMSLLHOOKSTRUCT;
{$R *.dfm}
function LowLevelMouseProc(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; stdcall;
var
Delta:Smallint;
begin
if (nCode >= 0) then
begin
Form3.Caption := Format('X: %d Y: %d ', [PMSLLHOOKSTRUCT(lParam)^.Point.X, PMSLLHOOKSTRUCT(lParam)^.Point.Y]);
if wParam = WM_LButtonDOWN then Form3.Caption := Form3.Caption + ' LD';
if wParam = WM_LButtonUP then Form3.Caption := Form3.Caption + ' LU';
if wParam = WM_RButtonDOWN then Form3.Caption := Form3.Caption + ' RD';
if wParam = WM_RButtonUP then Form3.Caption := Form3.Caption + ' RU';
if wParam = WM_MOUSEMOVE then Form3.Caption := Form3.Caption + ' Move';
Delta := PMSLLHOOKSTRUCT(lParam)^.mouseData shr 16;
if wParam = WM_MOUSEWHEEL then
begin
Form3.Caption := Form3.Caption + ' Wheel ' ;
if Delta=120 then Form3.Caption := Form3.Caption + ' KLICK'
else if Delta > 0 then Form3.Caption := Form3.Caption +' UP'
else if Delta < 0 then Form3.Caption := Form3.Caption +' DOWN'
end;
if wParam = WM_MOUSEHWHEEL then
begin
Form3.Caption := Form3.Caption + ' HWheel';
if Delta=120 then Form3.Caption := Form3.Caption + ' KLICK'
else if Delta > 0 then Form3.Caption := Form3.Caption +' UP'
else if Delta < 0 then Form3.Caption := Form3.Caption +' DOWN'
end;
Form3.Caption := Form3.Caption +' >> '+ IntToStr(Delta)
end;
Result := CallNextHookEx(HookHandle, nCode, wParam, lParam);
end;
function InstallMouseHook: Boolean;
begin
Result := False;
if HookHandle = 0 then
begin
HookHandle := SetWindowsHookEx(WH_MOUSE_LL, #LowLevelMouseProc, hInstance, 0);
Result := HookHandle <> 0;
end;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
InstallMouseHook;
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
if HookHandle <> 0 then
UnhookWindowsHookEx(HookHandle);
end;
end.
I have accepted the answer above, but my final version of this implementation is quite different. I thought I'd share what I came up with, as implementing a unique mouse hook multiple times was a little tricky.
Now the demonstration bummi provided was fixed and built-in to the form's unit. I created a new unit and wrapped everything in there. The tricky part was that the function LowLevelMouseProc cannot be part of the class. Yet, within this function, it makes a call specific to the hook handle (Result := CallNextHookEx(HookHandle, nCode, wParam, lParam);). So what I did was created a bucket (TList) where I dump every instance of my mouse object. When this function is called, it iterates through this bucket and triggers the appropriate events of each instance. This model also includes built-in thread-safe protection (untested).
Here's the full unit:
JD.Mouse.pas
unit JD.Mouse;
interface
uses
Windows, Classes, SysUtils, Messages, Controls;
type
TJDMouseButtonPoints = Array[TMouseButton] of TPoint;
TJDMouseButtonStates = Array[TMouseButton] of Boolean;
TJDMouse = class(TComponent)
private
FOnButtonUp: TMouseEvent;
FOnMove: TMouseMoveEvent;
FOnButtonDown: TMouseEvent;
FButtonPoints: TJDMouseButtonPoints;
FButtonStates: TJDMouseButtonStates;
procedure SetCursorPos(const Value: TPoint);
function GetCursorPos: TPoint;
procedure DoButtonDown(const IsDown: Boolean; const Button: TMouseButton;
const Shift: TShiftState; const X, Y: Integer);
procedure DoMove(const Shift: TShiftState; const X, Y: Integer);
public
constructor Create(AOwner: TComponent);
destructor Destroy; override;
published
property CursorPos: TPoint read GetCursorPos write SetCursorPos;
property OnButtonDown: TMouseEvent read FOnButtonDown write FOnButtonDown;
property OnButtonUp: TMouseEvent read FOnButtonUp write FOnButtonUp;
property OnMove: TMouseMoveEvent read FOnMove write FOnMove;
end;
implementation
var
_Hook: Cardinal;
_Bucket: TList;
_Lock: TRTLCriticalSection;
procedure LockMouse;
begin
EnterCriticalSection(_Lock);
end;
procedure UnlockMouse;
begin
LeaveCriticalSection(_Lock);
end;
type
tagMSLLHOOKSTRUCT = record
POINT: TPoint;
mouseData: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: DWORD;
end;
TMSLLHOOKSTRUCT = tagMSLLHOOKSTRUCT;
PMSLLHOOKSTRUCT = ^TMSLLHOOKSTRUCT;
function LowLevelMouseProc(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; stdcall;
var
X: Integer;
Delta: Smallint;
M: TJDMouse;
P: TPoint;
Shift: TShiftState;
begin
if (nCode >= 0) then begin
LockMouse;
try
Delta := PMSLLHOOKSTRUCT(lParam)^.mouseData shr 16;
try
for X := 0 to _Bucket.Count - 1 do begin
try
M:= TJDMouse(_Bucket[X]);
P:= Controls.Mouse.CursorPos;
//Shift:= .....; //TODO
case wParam of
WM_LBUTTONDOWN: begin
M.DoButtonDown(True, mbLeft, Shift, P.X, P.Y);
end;
WM_LBUTTONUP: begin
M.DoButtonDown(False, mbLeft, Shift, P.X, P.Y);
end;
WM_RBUTTONDOWN: begin
M.DoButtonDown(True, mbRight, Shift, P.X, P.Y);
end;
WM_RBUTTONUP: begin
M.DoButtonDown(False, mbRight, Shift, P.X, P.Y);
end;
WM_MBUTTONDOWN: begin
M.DoButtonDown(True, mbMiddle, Shift, P.X, P.Y);
end;
WM_MBUTTONUP: begin
M.DoButtonDown(False, mbMiddle, Shift, P.X, P.Y);
end;
WM_MOUSEMOVE: begin
M.DoMove(Shift, P.X, P.Y);
end;
WM_MOUSEWHEEL: begin
//TODO
end;
WM_MOUSEHWHEEL: begin
//TODO
end;
end;
except
on e: exception do begin
//TODO
end;
end;
end;
except
on e: exception do begin
//TODO
end;
end;
finally
UnlockMouse;
end;
end;
Result:= CallNextHookEx(_Hook, nCode, wParam, lParam);
end;
{ TJDMouse }
constructor TJDMouse.Create(AOwner: TComponent);
begin
LockMouse;
try
_Bucket.Add(Self); //Add self to bucket, registering to get events
finally
UnlockMouse;
end;
end;
destructor TJDMouse.Destroy;
begin
LockMouse;
try
_Bucket.Delete(_Bucket.IndexOf(Self)); //Remove self from bucket
finally
UnlockMouse;
end;
inherited;
end;
procedure TJDMouse.DoButtonDown(const IsDown: Boolean;
const Button: TMouseButton; const Shift: TShiftState; const X, Y: Integer);
begin
//Do not use lock, this is called from the lock already
if IsDown then begin
if assigned(FOnButtonDown) then
FOnButtonDown(Self, Button, Shift, X, Y);
end else begin
if assigned(FOnButtonUp) then
FOnButtonUp(Self, Button, Shift, X, Y);
end;
end;
procedure TJDMouse.DoMove(const Shift: TShiftState; const X, Y: Integer);
begin
//Do not use lock, this is called from the lock already
if assigned(FOnMove) then
FOnMove(Self, Shift, X, Y);
end;
function TJDMouse.GetCursorPos: TPoint;
begin
LockMouse;
try
Result:= Controls.Mouse.CursorPos;
finally
UnlockMouse;
end;
end;
procedure TJDMouse.SetCursorPos(const Value: TPoint);
begin
LockMouse;
try
Controls.Mouse.CursorPos:= Value;
finally
UnlockMouse;
end;
end;
initialization
InitializeCriticalSection(_Lock);
_Bucket:= TList.Create;
_Hook:= SetWindowsHookEx(WH_MOUSE_LL, #LowLevelMouseProc, hInstance, 0);
finalization
UnhookWindowsHookEx(_Hook);
_Bucket.Free;
DeleteCriticalSection(_Lock);
end.
And here's how it's implemented:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FMouse: TJDMouse;
procedure MouseButtonDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseButtonUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseMoved(Sender: TObject; Shift: TShiftState; X, Y: Integer);
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
FMouse:= TJDMouse.Create(nil);
FMouse.OnButtonDown:= MouseButtonDown;
FMouse.OnButtonUp:= MouseButtonUp;
FMouse.OnMove:= MouseMoved;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FMouse.Free;
end;
procedure TForm1.MouseButtonDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
end;
procedure TForm1.MouseButtonUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
end;
procedure TForm1.MouseMoved(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
end;
end.
You can use the TControlStyle.csCaptureMouse flag if you're using VCL controls. I'm not sure if there is a FMX counterpart. Relevant docs here.
I use csCaptureMouse in many of my custom controls and it works well.

How To Zoom with keeping aspect ratio correctly

Well this is my goal.
Use left mouse button to scroll the image, right mouse button to
choose zoom rectangle and doubleclick to restore full zoom.
I have currently tired, so far found its NOT to do with the way i load the images or display the image but something with how it paints. The on-screen image always fills the control's client area regardless of the shape of the form or the source image, so the aspect ratio cannot possibly be preserved. I am not sure how to change this or keep the aspect ratio. Thus giving me a clean nice picture.
I am posting the whole code for my ZImage unit Though i think the problem is either in the Zimage.paint or Zimage.mouseup But figured if you needed to see a function inside one of those it would help to have it all posted.
unit ZImage;
interface
uses
Windows, Messages, SysUtils,jpeg, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TZImage = class(TGraphicControl)
private
FBitmap : Tbitmap;
PicRect : TRect;
ShowRect : TRect;
FShowBorder : boolean;
FBorderWidth : integer;
FForceRepaint : boolean;
FMouse : (mNone, mDrag, mZoom);
FProportional : boolean;
FDblClkEnable : boolean;
FLeft :integer;
FRight :integer;
FTop :integer;
FBottom :integer;
startx, starty,
oldx, oldy : integer;
procedure SetShowBorder(s:boolean);
procedure SetBitmap(b:TBitmap);
procedure SetBorderWidth(w:integer);
procedure SetProportional(b:boolean);
protected
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
public
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
procedure DblClick; override;
published
procedure zoom(Endleft,EndRight,EndTop,EndBottom:integer);
property ValueLeft : integer read FLeft write FLeft;
property ValueRight : Integer read FRight write FRight;
Property ValueTop : Integer read FTop write FTop;
Property ValueBottom : Integer read FBottom write FBottom;
property ShowBorder : boolean
read FShowBorder
write SetShowBorder default true;
property KeepAspect : boolean
read FProportional
write SetProportional default true;
property Bitmap : TBitmap
read FBitmap
write Setbitmap;
property BorderWidth : integer
read FBorderWidth
write SetBorderWidth default 7;
property ForceRepaint : boolean
read FForceRepaint
write FForceRepaint default true;
property DblClkEnable : boolean
read FDblClkEnable
write FDblClkEnable default False;
property Align;
property Width;
property Height;
property Top;
property Left;
property Visible;
property Hint;
property ShowHint;
end;
procedure Register;
implementation
//This is the basic create options.
constructor TZImage.Create(AOwner:TComponent);
begin
inherited;
FShowBorder:=True;
FBorderWidth:=7;
FMouse:=mNone;
FForceRepaint:=true; //was true
FDblClkEnable:=False;
FProportional:=true; //was true
Width:=100; Height:=100;
FBitmap:=Tbitmap.Create;
FBitmap.Width:=width;
FBitmap.height:=Height;
ControlStyle:=ControlStyle+[csOpaque];
autosize:= false;
//Scaled:=false;
end;
//basic destroy frees the FBitmap
destructor TZImage.Destroy;
begin
FBitmap.Free;
inherited;
end;
//This was a custom zoom i was using to give the automated zoom effect
procedure TZimage.zoom(Endleft,EndRight,EndTop,EndBottom:integer);
begin
while ((Endbottom <> picrect.bottom) or (Endtop <> picrect.top)) or ((endleft <> picrect.left) or (endright <> picrect.right)) do
begin
if picrect.left > endleft then
picrect.left := picrect.left -1;
if picrect.left < endleft then //starting
picrect.left := picrect.left +1;
if picrect.right > endright then //starting
picrect.right := picrect.right -1;
if picrect.right < endright then
picrect.right := picrect.right +1;
if picrect.top > endtop then
picrect.top := picrect.top -1;
if picrect.top < endtop then //starting
picrect.top := picrect.top +1;
if picrect.bottom > endbottom then //starting
picrect.bottom := picrect.bottom -1;
if picrect.bottom < endbottom then
picrect.bottom := picrect.bottom +1;
self.refresh;
end;
end;
//this is the custom paint I know if i put
//Canvas.Draw(0,0,FBitmap); as the methond it displays
//perfect but the zoom option is gone of course and
//i need the Zoom.
procedure TZImage.Paint;
var buf:TBitmap;
coef,asps,aspp:Double;
sz,a : integer;
begin
buf:=TBitmap.Create;
buf.Width:=Width;
buf.Height:=Height;
if not FShowBorder
then ShowRect:=ClientRect
else ShowRect:=Rect(ClientRect.Left,ClientRect.Top,
ClientRect.Right-FBorderWidth,
ClientRect.Bottom-FBorderWidth);
ShowRect:=ClientRect;
with PicRect do begin
if Right=0 then Right:=FBitmap.Width;
if Bottom=0 then Bottom:=FBitmap.Height;
end;
buf.Canvas.CopyMode:=cmSrcCopy;
buf.Canvas.CopyRect(ShowRect,FBitmap.Canvas,PicRect);
Canvas.CopyMode:=cmSrcCopy;
Canvas.Draw(0,0,buf);
buf.Free;
end;
procedure TZImage.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
// if mbLeft<>Button then Exit;
if not PtInRect(ShowRect,Point(X,Y)) and
not PtInRect(Rect(ShowRect.Right,ShowRect.Bottom,
Width,Height),Point(X,Y)) then Exit;
if PtInRect(Rect(ShowRect.Right,ShowRect.Bottom,
Width,Height),Point(X,Y)) then begin
DblClick;
Exit;
end;
//here click is in the picture area only
startx:=x; oldx:=x;
starty:=y; oldy:=y;
if mbRight=Button then begin
MouseCapture:=True;
FMouse:=mZoom;
Canvas.Pen.Mode:=pmNot;
end else begin
FMouse:=mDrag;
Screen.Cursor:=crHandPoint;
end;
end;
function Min(a,b:integer):integer;
begin
if a<b then Result:=a else Result:=b;
end;
function Max(a,b:integer):integer;
begin
if a<b then Result:=b else Result:=a;
end;
procedure TZImage.MouseMove(Shift: TShiftState; X, Y: Integer);
var d,s:integer;
coef:Double;
begin
if FMouse=mNone then Exit;
if FMouse=mZoom then begin
Canvas.DrawFocusRect(Rect(Min(startx,oldx),Min(starty,oldy),Max(startx,oldx),Max(starty,oldy)));
oldx:=x; oldy:=y;
Canvas.DrawFocusRect(Rect(Min(startx,oldx),Min(starty,oldy),Max(startx,oldx),Max(starty,oldy)));
end;
if FMouse=mDrag then begin
//horizontal movement
coef:=(PicRect.Right-PicRect.Left)/(ShowRect.Right-ShowRect.Left);
d:=Round(coef*(x-oldx));
s:=PicRect.Right-PicRect.Left;
if d>0 then begin
if PicRect.Left>=d then begin
PicRect.Left:=PicRect.Left-d;
PicRect.Right:=PicRect.Right-d;
end else begin
PicRect.Left:=0;
PicRect.Right:=PicRect.Left+s;
end;
end;
if d<0 then begin
if PicRect.Right<FBitmap.Width+d then begin
PicRect.Left:=PicRect.Left-d;
PicRect.Right:=PicRect.Right-d;
end else begin
PicRect.Right:=FBitmap.Width;
PicRect.Left:=PicRect.Right-s;
end;
end;
//vertical movement
coef:=(PicRect.Bottom-PicRect.Top)/(ShowRect.Bottom-ShowRect.Top);
d:=Round(coef*(y-oldy));
s:=PicRect.Bottom-PicRect.Top;
if d>0 then begin
if PicRect.Top>=d then begin
PicRect.Top:=PicRect.Top-d;
PicRect.Bottom:=PicRect.Bottom-d;
end else begin
PicRect.Top:=0;
PicRect.Bottom:=PicRect.Top+s;
end;
end;
{There was a bug in the fragment below. Thanks to all, who reported this bug to me}
if d<0 then begin
if PicRect.Bottom<FBitmap.Height+d then begin
PicRect.Top:=PicRect.Top-d;
PicRect.Bottom:=PicRect.Bottom-d;
end else begin
PicRect.Bottom:=FBitmap.Height;
PicRect.Top:=PicRect.Bottom-s;
end;
end;
oldx:=x; oldy:=y;
if FForceRepaint then Repaint
else Invalidate;
end;
end;
procedure TZImage.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var coef:Double;
t:integer;
left,right,top,bottom : integer;
begin
if FMouse=mNone then Exit;
if x>ShowRect.Right then x:=ShowRect.Right;
if y>ShowRect.Bottom then y:=ShowRect.Bottom;
if FMouse=mZoom then begin //calculate new PicRect
t:=startx;
startx:=Min(startx,x);
x:=Max(t,x);
t:=starty;
starty:=Min(starty,y);
y:=Max(t,y);
FMouse:=mNone;
MouseCapture:=False;
//enable the following if you want to zoom-out by dragging in the opposite direction}
{ if Startx>x then begin
DblClick;
Exit;
end;}
if Abs(x-startx)<5 then Exit;
//showmessage('picrect Left='+inttostr(picrect.Left)+' right='+inttostr(picrect.Right)+' top='+inttostr(picrect.Top)+' bottom='+inttostr(picrect.Bottom));
//startx and start y is teh starting x/y of the selected area
//x and y is the ending x/y of the selected area
if (x - startx < y - starty) then
begin
while (x - startx < y - starty) do
begin
x := x + 100;
startx := startx - 100;
end;
end
else if (x - startx > y - starty) then
begin
while (x - startx > y - starty) do
begin
y := y + 100;
starty := starty - 100;
end;
end;
//picrect is the size of whole area
//PicRect.top and left are 0,0
//IFs were added in v.1.2 to avoid zero-divide
if (PicRect.Right=PicRect.Left)
then
coef := 100000
else
coef:=ShowRect.Right/(PicRect.Right-PicRect.Left); //if new screen coef= 1
left:=Round(PicRect.Left+startx/coef);
Right:=Left+Round((x-startx)/coef);
if (PicRect.Bottom=PicRect.Top)
then
coef := 100000
else
coef:=ShowRect.Bottom/(PicRect.Bottom-PicRect.Top);
Top:=Round(PicRect.Top+starty/coef);
Bottom:=Top+Round((y-starty)/coef);
//showmessage(inttostr(left)+' '+inttostr(Right)+' '+inttostr(top)+' '+inttostr(bottom));
zoom(left,right,top,bottom);
ValueLeft := left;
ValueRight := Right;
ValueTop := top;
ValueBottom := bottom;
end;
if FMouse=mDrag then begin
FMouse:=mNone;
Canvas.Pen.Mode:=pmCopy;
Screen.Cursor:=crDefault;
end;
Invalidate;
end;
procedure TZImage.DblClick;
begin
zoom(0,FBitMap.Width,0,FBitMap.Height);
ValueLeft := 0;
ValueRight := FBitMap.Width;
ValueTop := 0;
ValueBottom := FBitMap.Height;
//PicRect:=Rect(0,0,FBitmap.Width,FBitmap.Height);
Invalidate;
end;
procedure TZImage.SetBitmap(b:TBitmap);
begin
FBitmap.Assign(b);
PicRect:=Rect(0,0,b.Width, b.Height);
Invalidate;
end;
procedure TZImage.SetBorderWidth(w:integer);
begin
FBorderWidth:=w;
Invalidate;
end;
procedure TZImage.SetShowBorder(s:boolean);
begin
FShowBorder:=s;
Invalidate;
end;
procedure TZImage.SetProportional(b:boolean);
begin
FProportional:=b;
Invalidate;
end;
procedure Register;
begin
RegisterComponents('Custom', [TZImage]);
end;
end.
With this code you can register the componet ZImage and see how it runs.. if needed
The question is clear, but I think the problem answering it is how not to rewrite the complete code to be understandable for you. And since I am better at coding then explaining, I did.
I think you are searching for something like the following:
unit ZImage2;
interface
uses
Windows, Messages, Classes, Controls, Graphics, StdCtrls, ExtCtrls, Math;
const
DefAnimDuration = 500;
type
TZImage = class(TGraphicControl)
private
FAlignment: TAlignment;
FAnimDuration: Cardinal;
FAnimRect: TRect;
FAnimStartTick: Cardinal;
FAnimTimer: TTimer;
FBuffer: TBitmap;
FCropRect: TRect;
FImgRect: TRect;
FLayout: TTextLayout;
FPicture: TPicture;
FPrevCropRect: TRect;
FProportional: Boolean;
FProportionalCrop: Boolean;
FScale: Single;
FSelColor: TColor;
FSelecting: Boolean;
FSelPoint: TPoint;
FSelRect: TRect;
procedure Animate(Sender: TObject);
function HasGraphic: Boolean;
procedure PictureChanged(Sender: TObject);
procedure RealignImage;
procedure SetAlignment(Value: TAlignment);
procedure SetLayout(Value: TTextLayout);
procedure SetPicture(Value: TPicture);
procedure SetProportional(Value: Boolean);
procedure UpdateBuffer;
protected
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
procedure ChangeScale(M: Integer; D: Integer); override;
procedure DblClick; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Reset;
function ScreenToGraphic(R: TRect): TRect;
procedure Zoom(const ACropRect: TRect);
procedure ZoomSelection(const ASelRect: TRect);
published
property Alignment: TAlignment read FAlignment write SetAlignment
default taLeftJustify;
property AnimDuration: Cardinal read FAnimDuration write FAnimDuration
default DefAnimDuration;
property Layout: TTextLayout read FLayout write SetLayout default tlTop;
property Picture: TPicture read FPicture write SetPicture;
property Proportional: Boolean read FProportional write SetProportional
default False;
property ProportionalCrop: Boolean read FProportionalCrop
write FProportionalCrop default True;
property SelColor: TColor read FSelColor write FSelColor default clWhite;
published
property Align;
property Anchors;
property AutoSize;
property Color;
end;
implementation
function FitRect(const Boundary: TRect; Width, Height: Integer;
CanGrow: Boolean; HorzAlign: TAlignment; VertAlign: TTextLayout): TRect;
var
W: Integer;
H: Integer;
Scale: Single;
Offset: TPoint;
begin
Width := Max(1, Width);
Height := Max(1, Height);
W := Boundary.Right - Boundary.Left;
H := Boundary.Bottom - Boundary.Top;
if CanGrow then
Scale := Min(W / Width, H / Height)
else
Scale := Min(1, Min(W / Width, H / Height));
Result := Rect(0, 0, Round(Width * Scale), Round(Height * Scale));
case HorzAlign of
taLeftJustify:
Offset.X := 0;
taCenter:
Offset.X := (W - Result.Right) div 2;
taRightJustify:
Offset.X := W - Result.Right;
end;
case VertAlign of
tlTop:
Offset.Y := 0;
tlCenter:
Offset.Y := (H - Result.Bottom) div 2;
tlBottom:
Offset.Y := H - Result.Bottom;
end;
OffsetRect(Result, Boundary.Left + Offset.X, Boundary.Top + Offset.Y);
end;
function NormalizeRect(const Point1, Point2: TPoint): TRect;
begin
Result.Left := Min(Point1.X, Point2.X);
Result.Top := Min(Point1.Y, Point2.Y);
Result.Right := Max(Point1.X, Point2.X);
Result.Bottom := Max(Point1.Y, Point2.Y);
end;
{ TZImage }
procedure TZImage.Animate(Sender: TObject);
var
Done: Single;
begin
Done := (GetTickCount - FAnimStartTick) / FAnimDuration;
if Done >= 1.0 then
begin
FAnimTimer.Enabled := False;
FAnimRect := FCropRect;
end
else
with FPrevCropRect do
FAnimRect := Rect(
Left + Round(Done * (FCropRect.Left - Left)),
Top + Round(Done * (FCropRect.Top - Top)),
Right + Round(Done * (FCropRect.Right - Right)),
Bottom + Round(Done * (FCropRect.Bottom - Bottom)));
UpdateBuffer;
RealignImage;
Invalidate;
end;
function TZImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
Result := True;
if not (csDesigning in ComponentState) or HasGraphic then
begin
if Align in [alNone, alLeft, alRight] then
NewWidth := Round(FScale * FPicture.Width);
if Align in [alNone, alTop, alBottom] then
NewHeight := Round(FScale * FPicture.Height);
end;
end;
procedure TZImage.ChangeScale(M, D: Integer);
var
SaveAnchors: TAnchors;
begin
SaveAnchors := Anchors;
Anchors := [akLeft, akTop];
FScale := FScale * M / D;
inherited ChangeScale(M, D);
Anchors := SaveAnchors;
end;
constructor TZImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csCaptureMouse, csClickEvents, csOpaque, csDoubleClicks];
FAnimTimer := TTimer.Create(Self);
FAnimTimer.Interval := 15;
FAnimTimer.OnTimer := Animate;
FAnimDuration := DefAnimDuration;
FBuffer := TBitmap.Create;
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
FProportionalCrop := True;
FScale := 1.0;
FSelColor := clWhite;
end;
procedure TZImage.DblClick;
begin
if not HasGraphic then
Reset
else
Zoom(Rect(0, 0, FPicture.Width, FPicture.Height));
inherited DblClick;
end;
destructor TZImage.Destroy;
begin
FPicture.Free;
FBuffer.Free;
inherited Destroy;
end;
function TZImage.HasGraphic: Boolean;
begin
Result := (Picture.Width > 0) and (Picture.Height > 0);
end;
procedure TZImage.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
if (Button = mbRight) and HasGraphic and PtInRect(FImgRect, Point(X, Y)) then
begin
FSelPoint.X := X;
FSelPoint.Y := Y;
FSelRect := Rect(X, Y, X, Y);
FSelecting := True;
Canvas.Brush.Color := FSelColor;
Canvas.DrawFocusRect(FSelRect);
end;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TZImage.MouseMove(Shift: TShiftState; X, Y: Integer);
const
HorzAlign: array[Boolean] of TAlignment = (taLeftJustify, taRightJustify);
VertAlign: array[Boolean] of TTextLayout = (tlTop, tlBottom);
begin
if FSelecting and PtInRect(FImgRect, Point(X, Y)) then
begin
Canvas.DrawFocusRect(FSelRect);
FSelRect := NormalizeRect(FSelPoint, Point(X, Y));
if (not FProportionalCrop) then
FSelRect := FitRect(FSelRect, FPicture.Graphic.Width,
FPicture.Graphic.Height, True, HorzAlign[X < FSelPoint.X],
VertAlign[Y < FSelPoint.Y]);
Canvas.DrawFocusRect(FSelRect);
end;
inherited MouseMove(Shift, X, Y);
end;
procedure TZImage.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
if FSelecting then
begin
FSelecting := False;
Canvas.DrawFocusRect(FSelRect);
if (Abs(X - FSelPoint.X) > Mouse.DragThreshold) or
(Abs(Y - FSelPoint.Y) > Mouse.DragThreshold) then
ZoomSelection(FSelRect);
end;
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TZImage.Paint;
begin
Canvas.Brush.Color := Color;
if HasGraphic then
begin
Canvas.StretchDraw(FImgRect, FBuffer);
if FSelecting then
Canvas.DrawFocusRect(FSelRect);
with FImgRect do
ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom);
end;
Canvas.FillRect(Canvas.ClipRect);
end;
procedure TZImage.PictureChanged(Sender: TObject);
begin
Reset;
end;
procedure TZImage.RealignImage;
begin
if not HasGraphic then
FImgRect := Rect(0, 0, 0, 0)
else if FProportional then
FImgRect := ClientRect
else
FImgRect := FitRect(ClientRect, FBuffer.Width, FBuffer.Height, True,
FAlignment, FLayout);
end;
procedure TZImage.Reset;
begin
FCropRect := Rect(0, 0, FPicture.Width, FPicture.Height);
FAnimRect := FCropRect;
UpdateBuffer;
RealignImage;
Invalidate;
end;
procedure TZImage.Resize;
begin
RealignImage;
inherited Resize;
end;
function TZImage.ScreenToGraphic(R: TRect): TRect;
var
CropWidth: Integer;
CropHeight: Integer;
ImgWidth: Integer;
ImgHeight: Integer;
begin
CropWidth := FCropRect.Right - FCropRect.Left;
CropHeight := FCropRect.Bottom - FCropRect.Top;
ImgWidth := FImgRect.Right - FImgRect.Left;
ImgHeight := FImgRect.Bottom - FImgRect.Top;
IntersectRect(R, R, FImgRect);
OffsetRect(R, -FImgRect.Left, -FImgRect.Top);
Result := Rect(
FCropRect.Left + Round(CropWidth * (R.Left / ImgWidth)),
FCropRect.Top + Round(CropHeight * (R.Top / ImgHeight)),
FCropRect.Left + Round(CropWidth * (R.Right / ImgWidth)),
FCropRect.Top + Round(CropHeight * (R.Bottom / ImgHeight)));
end;
procedure TZImage.SetAlignment(Value: TAlignment);
begin
if FAlignment <> Value then
begin
FAlignment := Value;
RealignImage;
Invalidate;
end;
end;
procedure TZImage.SetLayout(Value: TTextLayout);
begin
if FLayout <> Value then
begin
FLayout := Value;
RealignImage;
Invalidate;
end;
end;
procedure TZImage.SetPicture(Value: TPicture);
begin
FPicture.Assign(Value);
end;
procedure TZImage.SetProportional(Value: Boolean);
begin
if FProportional <> Value then
begin
FProportional := Value;
RealignImage;
Invalidate;
end;
end;
procedure TZImage.UpdateBuffer;
begin
if HasGraphic then
begin
FBuffer.Width := FAnimRect.Right - FAnimRect.Left;
FBuffer.Height := FAnimRect.Bottom - FAnimRect.Top;
FBuffer.Canvas.Draw(-FAnimRect.Left, -FAnimRect.Top, FPicture.Graphic);
end;
end;
procedure TZImage.Zoom(const ACropRect: TRect);
begin
if HasGraphic then
begin
FPrevCropRect := FAnimRect;
FCropRect := ACropRect;
if FAnimDuration = 0 then
begin
FAnimRect := FCropRect;
UpdateBuffer;
RealignImage;
Invalidate;
end
else
begin
FAnimStartTick := GetTickCount;
FAnimTimer.Enabled := True;
end;
end;
end;
procedure TZImage.ZoomSelection(const ASelRect: TRect);
begin
Zoom(ScreenToGraphic(ASelRect));
end;
end.
Sample code:
procedure TForm1.FormCreate(Sender: TObject);
begin
FImage := TZImage.Create(Self);
FImage.SetBounds(10, 10, 200, 300);
FImage.Picture.LoadFromFile('D:\Pictures\Mona_Lisa.jpg');
FImage.Alignment := taCenter;
FImage.Layout := tlCenter;
FImage.AutoSize := True;
FImage.Parent := Self;
end;

How to implement a close button for a TTabsheet of a TPageControl

How can I implement a close button for a TTabsheet of a TPageControl like Firefox?
Edit:
Delphi Version: Delphi 2010
OS: Windows XP and up
Now with Theme support (include Windows, UxTheme, Themes units)!
type
TFormMain = class(TForm)
{...}
private
FCloseButtonsRect: array of TRect;
FCloseButtonMouseDownIndex: Integer;
FCloseButtonShowPushed: Boolean;
{...}
end;
{...}
procedure TFormMain.FormCreate(Sender: TObject);
var
I: Integer;
begin
PageControlCloseButton.TabWidth := 150;
PageControlCloseButton.OwnerDraw := True;
//should be done on every change of the page count
SetLength(FCloseButtonsRect, PageControlCloseButton.PageCount);
FCloseButtonMouseDownIndex := -1;
for I := 0 to Length(FCloseButtonsRect) - 1 do
begin
FCloseButtonsRect[I] := Rect(0, 0, 0, 0);
end;
end;
procedure TFormMain.PageControlCloseButtonDrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
CloseBtnSize: Integer;
PageControl: TPageControl;
TabCaption: TPoint;
CloseBtnRect: TRect;
CloseBtnDrawState: Cardinal;
CloseBtnDrawDetails: TThemedElementDetails;
begin
PageControl := Control as TPageControl;
if InRange(TabIndex, 0, Length(FCloseButtonsRect) - 1) then
begin
CloseBtnSize := 14;
TabCaption.Y := Rect.Top + 3;
if Active then
begin
CloseBtnRect.Top := Rect.Top + 4;
CloseBtnRect.Right := Rect.Right - 5;
TabCaption.X := Rect.Left + 6;
end
else
begin
CloseBtnRect.Top := Rect.Top + 3;
CloseBtnRect.Right := Rect.Right - 5;
TabCaption.X := Rect.Left + 3;
end;
CloseBtnRect.Bottom := CloseBtnRect.Top + CloseBtnSize;
CloseBtnRect.Left := CloseBtnRect.Right - CloseBtnSize;
FCloseButtonsRect[TabIndex] := CloseBtnRect;
PageControl.Canvas.FillRect(Rect);
PageControl.Canvas.TextOut(TabCaption.X, TabCaption.Y, PageControl.Pages[TabIndex].Caption);
if not UseThemes then
begin
if (FCloseButtonMouseDownIndex = TabIndex) and FCloseButtonShowPushed then
CloseBtnDrawState := DFCS_CAPTIONCLOSE + DFCS_PUSHED
else
CloseBtnDrawState := DFCS_CAPTIONCLOSE;
Windows.DrawFrameControl(PageControl.Canvas.Handle,
FCloseButtonsRect[TabIndex], DFC_CAPTION, CloseBtnDrawState);
end
else
begin
Dec(FCloseButtonsRect[TabIndex].Left);
if (FCloseButtonMouseDownIndex = TabIndex) and FCloseButtonShowPushed then
CloseBtnDrawDetails := ThemeServices.GetElementDetails(twCloseButtonPushed)
else
CloseBtnDrawDetails := ThemeServices.GetElementDetails(twCloseButtonNormal);
ThemeServices.DrawElement(PageControl.Canvas.Handle, CloseBtnDrawDetails,
FCloseButtonsRect[TabIndex]);
end;
end;
end;
procedure TFormMain.PageControlCloseButtonMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
I: Integer;
PageControl: TPageControl;
begin
PageControl := Sender as TPageControl;
if Button = mbLeft then
begin
for I := 0 to Length(FCloseButtonsRect) - 1 do
begin
if PtInRect(FCloseButtonsRect[I], Point(X, Y)) then
begin
FCloseButtonMouseDownIndex := I;
FCloseButtonShowPushed := True;
PageControl.Repaint;
end;
end;
end;
end;
procedure TFormMain.PageControlCloseButtonMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
PageControl: TPageControl;
Inside: Boolean;
begin
PageControl := Sender as TPageControl;
if (ssLeft in Shift) and (FCloseButtonMouseDownIndex >= 0) then
begin
Inside := PtInRect(FCloseButtonsRect[FCloseButtonMouseDownIndex], Point(X, Y));
if FCloseButtonShowPushed <> Inside then
begin
FCloseButtonShowPushed := Inside;
PageControl.Repaint;
end;
end;
end;
procedure TFormMain.PageControlCloseButtonMouseLeave(Sender: TObject);
var
PageControl: TPageControl;
begin
PageControl := Sender as TPageControl;
FCloseButtonShowPushed := False;
PageControl.Repaint;
end;
procedure TFormMain.PageControlCloseButtonMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
PageControl: TPageControl;
begin
PageControl := Sender as TPageControl;
if (Button = mbLeft) and (FCloseButtonMouseDownIndex >= 0) then
begin
if PtInRect(FCloseButtonsRect[FCloseButtonMouseDownIndex], Point(X, Y)) then
begin
ShowMessage('Button ' + IntToStr(FCloseButtonMouseDownIndex + 1) + ' pressed!');
FCloseButtonMouseDownIndex := -1;
PageControl.Repaint;
end;
end;
end;
Looks like:
It's often a good idea to implement this yourself, as the other answers have suggested. Just in case you are already using Raize Components, though, this feature is supported "out of the box". Just set TRzPageControl.ShowCloseButtonOnActiveTab := true, and handle the OnClose event. The component takes care of placement for a variety of tab layouts/orientations/shapes/colors.
[just a happy customer]
What I have done in the past is just put a TBitBtn with a graphic in the upper right hand corner of the TPageControl. The trick i the parent of the TBitBtn is the same as the TPageControl, so it isn't actually on one of the tab sheets. Then in the click even for that button:
PageControl1.ActivePage.Free;
When the current TTabControl is freed it notifies the TPageControl that owns it.
I have changed a little this example:
- created class TCloseTabSheet
- this class has property OnClose: TNotifyEvent, which will be called if assigned
- if TabSheet of of TPageControl isn't that class then there is no close button
- if it is then Button showed. When you press close button it calls OnClose
- now you dont need to control the array FCloseButtonsRect, cause this Rects stored at TCloseTabSheet
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, Themes, Math, ExtCtrls, StdCtrls;
type TCloseTabSheet=class(TTabSheet)
private
protected
FCloseButtonRect: TRect;
FOnClose: TNotifyEvent;
procedure DoClose; virtual;
public
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
property OnClose:TNotifyEvent read FOnClose write FOnClose;
end;
type
TMainForm = class(TForm)
PageControlCloseButton: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
procedure FormCreate(Sender: TObject);
procedure PageControlCloseButtonDrawTab(Control: TCustomTabControl; TabIndex: Integer;
const Rect: TRect; Active: Boolean);
procedure PageControlCloseButtonMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure PageControlCloseButtonMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
procedure PageControlCloseButtonMouseLeave(Sender: TObject);
procedure PageControlCloseButtonMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure CloseTabeProc(Sender: TObject);
private
FCloseButtonMouseDownTab: TCloseTabSheet;
FCloseButtonShowPushed: Boolean;
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
constructor TCloseTabSheet.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FCloseButtonRect:=Rect(0, 0, 0, 0);
end;
destructor TCloseTabSheet.Destroy;
begin
inherited Destroy;
end;
procedure TCloseTabSheet.DoClose;
begin
if Assigned(FOnClose) then FOnClose(Self);
Free;
end;
procedure TMainForm.CloseTabeProc(Sender: TObject);
begin
ShowMessage('close');
end;
procedure TMainForm.FormCreate(Sender: TObject);
var I: Integer;
NT:TCloseTabSheet;
begin
PageControlCloseButton.TabWidth := 150;
PageControlCloseButton.OwnerDraw := True;
NT:=TCloseTabSheet.Create(PageControlCloseButton);
NT.Caption:='TabSheet4';
NT.PageControl:=PageControlCloseButton;
NT.OnClose:=CloseTabeProc;
FCloseButtonMouseDownTab := nil;
end;
procedure TMainForm.PageControlCloseButtonDrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
CloseBtnSize: Integer;
PageControl: TPageControl;
TabSheet:TCloseTabSheet;
TabCaption: TPoint;
CloseBtnRect: TRect;
CloseBtnDrawState: Cardinal;
CloseBtnDrawDetails: TThemedElementDetails;
begin
PageControl := Control as TPageControl;
TabCaption.Y := Rect.Top + 3;
if Active then
begin
CloseBtnRect.Top := Rect.Top + 4;
CloseBtnRect.Right := Rect.Right - 5;
TabCaption.X := Rect.Left + 6;
end
else
begin
CloseBtnRect.Top := Rect.Top + 3;
CloseBtnRect.Right := Rect.Right - 5;
TabCaption.X := Rect.Left + 3;
end;
if PageControl.Pages[TabIndex] is TCloseTabSheet then
begin
TabSheet:=PageControl.Pages[TabIndex] as TCloseTabSheet;
CloseBtnSize := 14;
CloseBtnRect.Bottom := CloseBtnRect.Top + CloseBtnSize;
CloseBtnRect.Left := CloseBtnRect.Right - CloseBtnSize;
TabSheet.FCloseButtonRect := CloseBtnRect;
PageControl.Canvas.FillRect(Rect);
PageControl.Canvas.TextOut(TabCaption.X, TabCaption.Y,
PageControl.Pages[TabIndex].Caption);
if not ThemeServices.ThemesEnabled then
begin
if (FCloseButtonMouseDownTab = TabSheet) and FCloseButtonShowPushed then
CloseBtnDrawState := DFCS_CAPTIONCLOSE + DFCS_PUSHED
else
CloseBtnDrawState := DFCS_CAPTIONCLOSE;
Windows.DrawFrameControl(PageControl.Canvas.Handle,
TabSheet.FCloseButtonRect, DFC_CAPTION, CloseBtnDrawState);
end
else
begin
Dec(TabSheet.FCloseButtonRect.Left);
if (FCloseButtonMouseDownTab = TabSheet) and FCloseButtonShowPushed then
CloseBtnDrawDetails := ThemeServices.GetElementDetails(twCloseButtonPushed)
else
CloseBtnDrawDetails := ThemeServices.GetElementDetails(twCloseButtonNormal);
ThemeServices.DrawElement(PageControl.Canvas.Handle, CloseBtnDrawDetails,
TabSheet.FCloseButtonRect);
end;
end else begin
PageControl.Canvas.FillRect(Rect);
PageControl.Canvas.TextOut(TabCaption.X, TabCaption.Y,
PageControl.Pages[TabIndex].Caption);
end;
end;
procedure TMainForm.PageControlCloseButtonMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
I: Integer;
PageControl: TPageControl;
TabSheet:TCloseTabSheet;
begin
PageControl := Sender as TPageControl;
if Button = mbLeft then
begin
for I := 0 to PageControl.PageCount - 1 do
begin
if not (PageControl.Pages[i] is TCloseTabSheet) then Continue;
TabSheet:=PageControl.Pages[i] as TCloseTabSheet;
if PtInRect(TabSheet.FCloseButtonRect, Point(X, Y)) then
begin
FCloseButtonMouseDownTab := TabSheet;
FCloseButtonShowPushed := True;
PageControl.Repaint;
end;
end;
end;
end;
procedure TMainForm.PageControlCloseButtonMouseLeave(Sender: TObject);
var
PageControl: TPageControl;
begin
PageControl := Sender as TPageControl;
FCloseButtonShowPushed := False;
PageControl.Repaint;
end;
procedure TMainForm.PageControlCloseButtonMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
PageControl: TPageControl;
Inside: Boolean;
begin
PageControl := Sender as TPageControl;
if (ssLeft in Shift) and Assigned(FCloseButtonMouseDownTab) then
begin
Inside := PtInRect(FCloseButtonMouseDownTab.FCloseButtonRect, Point(X, Y));
if FCloseButtonShowPushed <> Inside then
begin
FCloseButtonShowPushed := Inside;
PageControl.Repaint;
end;
end;
end;
procedure TMainForm.PageControlCloseButtonMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
PageControl: TPageControl;
begin
PageControl := Sender as TPageControl;
if (Button = mbLeft) and Assigned(FCloseButtonMouseDownTab) then
begin
if PtInRect(FCloseButtonMouseDownTab.FCloseButtonRect, Point(X, Y)) then
begin
FCloseButtonMouseDownTab.DoClose;
FCloseButtonMouseDownTab := nil;
PageControl.Repaint;
end;
end;
end;
end.

Resources