Delphi, How to make a shape stop moving - delphi

I am trying to make a shape move towards onother using 2 shapes and 2 timer, but i really can't seem. I was thinking:
At the beggining, I will make shape 1 calculate the distance of shape 2 and then move towards it, this is what i have done, i have also added comments to help you understand the code, because it is a little bit confusing:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
timer1.Interval:=100; //set interval=200
//begin
if shape1.Left=shape2.Left then
begin
shape1.Left:=shape1.left //If shape's 1 coordinates = shape's 2 then
end else //shape1.left:=stop moving else do
begin //find if shape 2 is right or left from shape 1
if shape1.left>shape2.Left then
begin
shape1.Left:=shape1.Left-5;
end else shape1.Left:=shape1.Left+5;
//Moving to shape2.left until shape1.left:=shape2.left
end;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
timer2.Interval:=100; //the same method as timer1
if shape1.top=shape2.top then
begin
shape1.top:=shape1.top
end else
begin
if shape1.top>shape2.top then
begin
shape1.top:=shape1.top-5;
end else shape1.top:=shape1.top+5;
end;
end;
end.
What shape1 does now is to move toward shape 2, but it doesn't stop moving, i mean it sticks to shape 2, but it is still moving upside-down, but not left-right from shape 2. I checked timer's 2 code and there is nothing wrong.

Try the following code (assign OnCreate and OnPaint of the form and set the timer to 30 millisecond intervals):
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TVector = record
X, Y: real;
end;
TForm5 = class(TForm)
Timer1: TTimer;
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
FPosA, FPosB: TVector;
v: TVector;
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
uses Math;
{$R *.dfm}
const RADIUS = 16;
function RealPoint(X, Y: real): TVector;
begin
result.X := X;
result.Y := Y;
end;
function RoundPoint(P: TVector): TPoint;
begin
result.X := round(P.X);
result.Y := round(P.Y);
end;
procedure TForm5.FormCreate(Sender: TObject);
var
DX, DY: real;
begin
FPosA := RealPoint(32, 32);
FPosB := RealPoint(500, 200);
DX := FPosB.X - FPosA.X;
DY := FPosB.Y - FPosA.Y;
v.X := DX / 100;
v.Y := DY / 100;
end;
function EllipseRectFromPoint(P: TVector): TRect;
var
ScreenPoint: TPoint;
begin
ScreenPoint := RoundPoint(P);
result.Left := ScreenPoint.X - RADIUS;
result.Right := ScreenPoint.X + RADIUS;
result.Top := ScreenPoint.Y - RADIUS;
result.Bottom := ScreenPoint.Y + RADIUS;
end;
procedure TForm5.FormPaint(Sender: TObject);
begin
// Draw ball A
Canvas.Brush.Color := clSkyBlue;
Canvas.Ellipse(EllipseRectFromPoint(FPosA));
// Draw ball B
Canvas.Brush.Color := clMoneyGreen;
Canvas.Ellipse(EllipseRectFromPoint(FPosB));
end;
procedure TForm5.Timer1Timer(Sender: TObject);
begin
FPosA.X := FPosA.X + V.X;
FPosA.Y := FPosA.Y + V.Y;
Invalidate;
if Hypot(FPosA.X - FPosB.X, FPosA.Y - FPosB.Y) < 0.1 then
begin
Timer1.Enabled := false;
ShowMessage('We''re there!');
end;
end;
end.
Two balls:
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TVector = record
X, Y: real;
end;
TForm5 = class(TForm)
Timer1: TTimer;
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
AreWeThereYetA, AreWeThereYetB: boolean;
FPosA, FPosB, FPosC: TVector;
vA, vB: TVector;
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
uses Math;
{$R *.dfm}
const RADIUS = 16;
function RealPoint(X, Y: real): TVector;
begin
result.X := X;
result.Y := Y;
end;
function RoundPoint(P: TVector): TPoint;
begin
result.X := round(P.X);
result.Y := round(P.Y);
end;
procedure TForm5.FormCreate(Sender: TObject);
var
DX, DY: real;
begin
FPosA := RealPoint(32, 32);
FPosB := RealPoint(132, 32);
FPosC := RealPoint(500, 200);
DX := FPosC.X - FPosA.X;
DY := FPosC.Y - FPosA.Y;
vA.X := DX / 100;
vA.Y := DY / 100;
DX := FPosC.X - FPosB.X;
DY := FPosC.Y - FPosB.Y;
vB.X := DX / 200;
vB.Y := DY / 200;
end;
function EllipseRectFromPoint(P: TVector): TRect;
var
ScreenPoint: TPoint;
begin
ScreenPoint := RoundPoint(P);
result.Left := ScreenPoint.X - RADIUS;
result.Right := ScreenPoint.X + RADIUS;
result.Top := ScreenPoint.Y - RADIUS;
result.Bottom := ScreenPoint.Y + RADIUS;
end;
procedure TForm5.FormPaint(Sender: TObject);
begin
// Draw ball A
Canvas.Brush.Color := clSkyBlue;
Canvas.Ellipse(EllipseRectFromPoint(FPosA));
// Draw ball B
Canvas.Brush.Color := clMoneyGreen;
Canvas.Ellipse(EllipseRectFromPoint(FPosB));
// Draw ball C
Canvas.Brush.Color := clRed;
Canvas.Ellipse(EllipseRectFromPoint(FPosC));
end;
procedure TForm5.Timer1Timer(Sender: TObject);
begin
if not AreWeThereYetA then
begin
FPosA.X := FPosA.X + VA.X;
FPosA.Y := FPosA.Y + VA.Y;
end;
if not AreWeThereYetB then
begin
FPosB.X := FPosB.X + VB.X;
FPosB.Y := FPosB.Y + VB.Y;
end;
Invalidate;
if Hypot(FPosA.X - FPosC.X, FPosA.Y - FPosC.Y) < 0.1 then
AreWeThereYetA := true;
if Hypot(FPosB.X - FPosC.X, FPosB.Y - FPosC.Y) < 0.1 then
AreWeThereYetB := true;
if AreWeThereYetA and AreWeThereYetB then
begin
Timer1.Enabled := false;
ShowMessage('We are there!');
end;
end;
end.
Using arrays and records, it would be easily to generalise to N balls with custom properties (colours, radii, etc.), even random ones. It would also be very easy to implement bouncing. In addition, a real vector type would be good here.

Related

how to move two bitmap-image on a canvas

I am writing an animation program under Delphi 7 consisting of moving two discs on a canvas (I choose a PaintBox) with a bounce effect on the edges.
it's woks fine if I load the pictures one by one: In this case, when the two disks that arrive from time to time are superimposed, no background rectangle appears with even a rather pleasant transparency effect.
But if I try to generalize the operation with many more discs by introducing for example a Record.
The movements are ok BUT in this case, when the discs cross, a background
rectangle appears in the upper image which spoils everything!
I even tried to write the code with an Object with :
TSphere = class (TObject)
but nothing to do, the phenomenon remains ..
Do you have any idea how to remove this display defect?
and i have another question, i would like to fill the disks with textures.
the full code :
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, ComCtrls;
type
TSphere = record
W, H: integer;
vx, vy: Extended;
x, y: integer;
xx, yy: extended;
ROld, RNew: TRect;
Bitm: TBitmap;
end;
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
Button1: TButton;
Timer1: TTimer;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
TrackBar1: TTrackBar;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
end;
var
Form1: TForm1;
fin: boolean;
BmpBkg: Tbitmap;
BmpMoving: TBitmap;
Spheres: array of TSphere;
const
nb = 2;
ImageWidth = 32;
implementation
{$R *.DFM}
procedure PictureStorage;
var
i: integer;
begin
SetLength(Spheres, nb);
for i := 0 to (nb - 1) do
begin
with Spheres[i] do
begin
Bitm := TBitmap.Create;
case i of
0: Bitm.loadFromFile('Sphere1.bmp');
1: Bitm.loadFromFile('Sphere2.bmp');
end;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
begin
DoubleBuffered := true;
randomize;
Fin := false;
BmpBkg := TBitmap.Create;
BmpMoving := TBitmap.Create;
BmpBkg .Canvas.Brush.Color := ClBtnFace;
BmpBkg .Canvas.FillRect(Rect(0, 0, PaintBox1.height,
PaintBox1.width));
BmpBkg .Width := PaintBox1.Width;
BmpBkg .Height := PaintBox1.Height;
BmpMoving .Assign(BmpBkg );
PictureStorage;
for i := 0 to (nb - 1) do
begin
with Spheres[i] do
begin
W := Bitm.Width;
H := Bitm.Height;
Bitm.Transparent := True;
Bitm.TransParentColor := Bitm.canvas.pixels[1, 1];
xx := random(400) + 1;
yy := random(200) + 1;
x := trunc(xx);
y := trunc(yy);
vx := random(3) + 1;
vy := random(4) + 1;
RNew := bounds(x, y, W, H);
ROld := RNew;
end;
end;
Timer1.interval := 1;
Timer1.enabled := true;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i: integer;
begin
Fin := true;
BmpBkg.free;
BmpMoving.free;
for i := 0 to (nb - 1) do
Spheres[i].Bitm.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
PaintBox1.Canvas.Draw(0, 0, BmpMoving);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
close;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
n, i: integer;
Runion: Trect;
begin
for n := 1 to trackbar1.position do
begin
if fin then exit;
for i := 0 to (nb - 1) do
begin
with Spheres[i] do
begin
BmpMoving.Canvas.CopyRect(ROld, bmpBkg.canvas, ROld);
if (x < -ImageWidth) or (x > bmpBkg.width - W + ImageWidth)
then
vx := -vx;
if (y < 0) or (y > bmpBkg.height - H) then
vy := -vy;
xx := xx + vx;
yy := yy + vy;
x := trunc(xx);
y := trunc(yy);
RNew := bounds(x, y, W, H);
BmpMoving.Canvas.Draw(x, y, Bitm);
UnionRect(RUnion, ROld, RNew);
PaintBox1.Canvas.CopyRect(RUnion, BmpMoving.Canvas,
RUnion);
ROld := RNew;
end;
end;
end;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Edit1.text := inttostr(trackbar1.position);
if trackbar1.position = 1 then
label2.visible := true
else
label2.visible := false;
end;
end.
this program is just the start of another more important
thanks
Your code is almost OK.
As far as I can see your problem is caused by not completely restoring the background before you draw the bitmaps at their new locations. You need to restore the old rects of all spheres before you draw the new ones. Also you need to collect the complete union of all new and old rects before you update to screen.
As a matter of taste, I would avoid the global variables and make them fields of the form. If you also make PictureStorage a method of the form, everything works.
The timer interval of 1 seems a bit of an overkill. I would set it to 1000 div 120 (120 FPS).
I would set doublebuffered to false, as you are already doing your own doublebuffering. Also I would move the form's OnPaint to the paintbox's OnPaint, but that doesn't seem to work for you.
Here is the replacement of the OnTimer event which should work (I checked an analogue with Delphi 2006, I don't have Delphi7 installed anymore and I don't know what the n means).
procedure TForm1.Timer1Timer(Sender: TObject);
var
n, i: integer;
Runion: TRect;
begin
//I don't know what the n-loop is for, in my test I left it out
for n := 1 to TrackBar1.position do
begin
//prevent reentry?
if fin then
exit;
// Restore the background completely
for i := 0 to (nb - 1) do
with Spheres[i] do
begin
BmpMoving.Canvas.CopyRect(ROld, BmpBkg.Canvas, ROld);
// Collect the old rects into the update-rect
if i = 0 then
Runion := ROld
else
UnionRect(Runion, Runion, ROld);
end;
for i := 0 to (nb - 1) do
with Spheres[i] do
begin
if (x < -ImageWidth) or (x > BmpBkg.width - W + ImageWidth) then
vx := -vx;
if (y < 0) or (y > BmpBkg.height - H) then
vy := -vy;
xx := xx + vx;
yy := yy + vy;
x := trunc(xx);
y := trunc(yy);
RNew := bounds(x, y, W, H);
BmpMoving.Canvas.Draw(x, y, Bitm);
// Add RNew to RUnion
UnionRect(Runion, Runion, RNew);
// No painting yet, update the screen as few times as possible
ROld := RNew;
end;
//Now update the screen
//This is the reliable way for sherlock to update the screen:
OffsetRect(RUnion, Paintbox1.left, Paintbox1.top);
//RUnion in form's coordinates
InvalidateRect(Handle, #RUnion, false);
//The following works for me just as well:
(**************
PaintBox1.Canvas.CopyRect(Runion, BmpMoving.Canvas, Runion);
***************)
end;
end;
This code can be commented out.
Tt does not affect the program :
// Collect the old rects into the update-rect
{ if i = 0 then
Runion := ROld
else
UnionRect(Runion, Runion, ROld); }

Delphi7, make a shape jump when pressing Up key

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;

Delphi custom animation - collision detection

I'm working with custom drawing / 2D animation and I'm trying to figure out how to detect when the moving object collides with a wall in the map. User holds arrow keys on the keyboard to move the object, and the map is stored as an array structure of points. The walls in the map may be angled, but no curved walls.
Using the map structure (FMap: TMap;) in my code below, in the DoMove property, how do I detect if the object is colliding with any wall in the map and prevent it from moving through? In DoMove, I need to read FMap (refer to DrawMap to see how FMap works) and somehow determine if the object is approaching any wall and stop it.
I could do a dual X/Y loop iterating every possible pixel between each two points in each part of each map, but I already know this will be heavy, considering this procedure will be called rapidly so long as the object is moving.
I thought of reading the pixel colors in the direction the object's moving, and if there's any black (from map lines), consider it a wall. But eventually there will be more custom drawing of a background, so reading pixel colors wouldn't work.
uMain.pas
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls;
const
//Window client size
MAP_WIDTH = 500;
MAP_HEIGHT = 500;
type
TKeyStates = Array[0..255] of Bool;
TPoints = Array of TPoint;
TMap = Array of TPoints;
TForm1 = class(TForm)
Tmr: TTimer;
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure TmrTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
FBMain: TBitmap; //Main rendering image
FBMap: TBitmap; //Map image
FBObj: TBitmap; //Object image
FKeys: TKeyStates; //Keyboard states
FPos: TPoint; //Current object position
FMap: TMap; //Map line structure
procedure Render;
procedure DrawObj;
procedure DoMove;
procedure DrawMap;
procedure LoadMap;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Math, StrUtils;
procedure TForm1.FormCreate(Sender: TObject);
begin
FBMain:= TBitmap.Create;
FBMap:= TBitmap.Create;
FBObj:= TBitmap.Create;
ClientWidth:= MAP_WIDTH;
ClientHeight:= MAP_HEIGHT;
FBMain.Width:= MAP_WIDTH;
FBMain.Height:= MAP_HEIGHT;
FBMap.Width:= MAP_WIDTH;
FBMap.Height:= MAP_HEIGHT;
FBObj.Width:= MAP_WIDTH;
FBObj.Height:= MAP_HEIGHT;
FBObj.TransparentColor:= clWhite;
FBObj.Transparent:= True;
FPos:= Point(150, 150);
LoadMap; //Load map lines into array structure
DrawMap; //Draw map lines to map image only once
Tmr.Enabled:= True;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Tmr.Enabled:= False;
FBMain.Free;
FBMap.Free;
FBObj.Free;
end;
procedure TForm1.LoadMap;
begin
SetLength(FMap, 1); //Just one object on map
//Triangle
SetLength(FMap[0], 4); //4 points total
FMap[0][0]:= Point(250, 100);
FMap[0][1]:= Point(250, 400);
FMap[0][2]:= Point(100, 400);
FMap[0][3]:= Point(250, 100);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
FKeys[Key]:= True;
end;
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
FKeys[Key]:= False;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Draw(0, 0, FBMain); //Just draw rendered image to form
end;
procedure TForm1.DoMove;
const
SPD = 3; //Speed (pixels per movement)
var
X, Y: Integer;
P: TPoints;
begin
//How to keep object from passing through map walls?
if FKeys[VK_LEFT] then begin
//Check if there's a wall on the left
FPos.X:= FPos.X - SPD;
end;
if FKeys[VK_RIGHT] then begin
//Check if there's a wall on the right
FPos.X:= FPos.X + SPD;
end;
if FKeys[VK_UP] then begin
//Check if there's a wall on the top
FPos.Y:= FPos.Y - SPD;
end;
if FKeys[VK_DOWN] then begin
//Check if there's a wall on the bottom
FPos.Y:= FPos.Y + SPD;
end;
end;
procedure TForm1.DrawMap;
var
C: TCanvas;
X, Y: Integer;
P: TPoints;
begin
C:= FBMap.Canvas;
//Clear image first
C.Brush.Style:= bsSolid;
C.Pen.Style:= psClear;
C.Brush.Color:= clWhite;
C.FillRect(C.ClipRect);
//Draw map walls
C.Brush.Style:= bsClear;
C.Pen.Style:= psSolid;
C.Pen.Width:= 2;
C.Pen.Color:= clBlack;
for X := 0 to Length(FMap) - 1 do begin
P:= FMap[X]; //One single map object
for Y := 0 to Length(P) - 1 do begin
if Y = 0 then //First iteration only
C.MoveTo(P[Y].X, P[Y].Y)
else //All remaining iterations
C.LineTo(P[Y].X, P[Y].Y);
end;
end;
end;
procedure TForm1.DrawObj;
var
C: TCanvas;
R: TRect;
begin
C:= FBObj.Canvas;
//Clear image first
C.Brush.Style:= bsSolid;
C.Pen.Style:= psClear;
C.Brush.Color:= clWhite;
C.FillRect(C.ClipRect);
//Draw object in current position
C.Brush.Style:= bsClear;
C.Pen.Style:= psSolid;
C.Pen.Width:= 2;
C.Pen.Color:= clRed;
R.Left:= FPos.X - 10;
R.Right:= FPos.X + 10;
R.Top:= FPos.Y - 10;
R.Bottom:= FPos.Y + 10;
C.Ellipse(R);
end;
procedure TForm1.Render;
begin
//Combine map and object images into main image
FBMain.Canvas.Draw(0, 0, FBMap);
FBMain.Canvas.Draw(0, 0, FBObj);
Invalidate; //Repaint
end;
procedure TForm1.TmrTimer(Sender: TObject);
begin
DoMove; //Control movement of object
DrawObj; //Draw object
Render;
end;
end.
uMain.dfm
object Form1: TForm1
Left = 315
Top = 113
BorderIcons = [biSystemMenu]
BorderStyle = bsSingle
Caption = 'Form1'
ClientHeight = 104
ClientWidth = 207
Color = clBtnFace
DoubleBuffered = True
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
OnKeyDown = FormKeyDown
OnKeyUp = FormKeyUp
OnPaint = FormPaint
PixelsPerInch = 96
TextHeight = 13
object Tmr: TTimer
Enabled = False
Interval = 50
OnTimer = TmrTimer
Left = 24
Top = 8
end
end
PS - This code is just a stripped and dummied version of my full project to demonstrate how things work.
EDIT
I just realized an important factor: Right now, I've only implemented one moving object. However, there will be multiple moving objects as well. So, the collision may occur with either a map wall or another object (which I'll have each object in a list). The full project is still very raw like this sample, but much more code than is relevant for this question.
this unit found on the web (can't remember where, no author mentioned, perhaps someone can provide a link) would give you the ability of calculating collisions and reflection angles.
unit Vector;
interface
type
TPoint = record
X, Y: Double;
end;
TVector = record
X, Y: Double;
end;
TLine = record
P1, P2: TPoint;
end;
function Dist(P1, P2: TPoint): Double; overload;
function ScalarProd(P1, P2: TVector): Double;
function ScalarMult(P: TVector; V: Double): TVector;
function Subtract(V1, V2: TVector): TVector; overload;
function Subtract(V1, V2: TPoint): TVector; overload;
function MinDistPoint(Point: TPoint; Line: TLine): TPoint;
function Mirror(W, V: TVector): TVector;
function Dist(Point: TPoint; Line: TLine): Double; overload;
implementation
function Dist(P1, P2: TPoint): Double; overload;
begin
Result := Sqrt(Sqr(P1.X - P2.X) + Sqr(P1.Y - P2.Y));
end;
function ScalarProd(P1, P2: TVector): Double;
begin
Result := P1.X * P2.X + P1.Y * P2.Y;
end;
function ScalarMult(P: TVector; V: Double): TVector;
begin
Result.X := P.X * V;
Result.Y := P.Y * V;
end;
function Subtract(V1, V2: TVector): TVector; overload;
begin
Result.X := V2.X - V1.X;
Result.Y := V2.Y - V1.Y;
end;
function Subtract(V1, V2: TPoint): TVector; overload;
begin
Result.X := V2.X - V1.X;
Result.Y := V2.Y - V1.Y;
end;
function MinDistPoint(Point: TPoint; Line: TLine): TPoint;
var
U: Double;
P: TPoint;
begin
U := ((Point.X - Line.P1.X) * (Line.P2.X - Line.P1.X) +
(Point.Y - Line.P1.Y) * (Line.P2.Y - Line.P1.Y)) /
(Sqr(Line.P1.X - Line.P2.X) + Sqr(Line.P1.Y - Line.P2.Y));
if U <= 0 then
Exit(Line.P1);
if U >= 1 then
Exit(Line.P2);
P.X := Line.P1.X + U * (Line.P2.X - Line.P1.X);
P.Y := Line.P1.Y + U * (Line.P2.Y - Line.P1.Y);
Exit(P);
end;
function Mirror(W, V: TVector): TVector;
begin
Result := Subtract(ScalarMult(V, 2*ScalarProd(v,w)/ScalarProd(v,v)), W);
end;
function Dist(Point: TPoint; Line: TLine): Double; overload;
begin
Result := Dist(Point, MinDistPoint(Point, Line));
end;
end.
An example implementation would be
unit BSP;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Vector, ExtCtrls;
type
TForm2 = class(TForm)
Timer1: TTimer;
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private-Deklarationen }
FLines: array of TLine;
FP: TPoint;
FV: TVector;
FBallRadius: Integer;
FBallTopLeft: Windows.TPoint;
public
{ Public-Deklarationen }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
const
N = 5;
var
I: Integer;
begin
Randomize;
SetLength(FLines, 4 + N);
FBallRadius := 15;
// Walls
FLines[0].P1.X := 0;
FLines[0].P1.Y := 0;
FLines[0].P2.X := Width - 1;
FLines[0].P2.Y := 0;
FLines[1].P1.X := Width - 1;
FLines[1].P1.Y := 0;
FLines[1].P2.X := Width - 1;
FLines[1].P2.Y := Height - 1;
FLines[2].P1.X := Width - 1;
FLines[2].P1.Y := Height - 1;
FLines[2].P2.X := 0;
FLines[2].P2.Y := Height - 1;
FLines[3].P1.X := 0;
FLines[3].P1.Y := 0;
FLines[3].P2.X := 0;
FLines[3].P2.Y := Height - 1;
for I := 0 to N - 1 do
begin
FLines[I + 4].P1.X := 50 + Random(Width - 100);
FLines[I + 4].P1.Y := 50 + Random(Height - 100);
FLines[(I + 1) mod N + 4].P2 := FLines[I + 4].P1;
end;
FP.X := 50;
FP.Y := 50;
FV.X := 10;
FV.Y := 10;
end;
procedure TForm2.FormPaint(Sender: TObject);
const
Iterations = 100;
var
I, MinIndex, J: Integer;
MinDist, DP, DH: Double;
MP: TPoint;
H: TPoint;
begin
for I := 0 to Length(FLines) - 1 do
begin
Canvas.MoveTo(Round(FLines[I].P1.X), Round(FLines[I].P1.Y));
Canvas.LineTo(Round(FLines[I].P2.X), Round(FLines[I].P2.Y));
end;
for I := 0 to Iterations do
begin
H := FP;
FP.X := FP.X + FV.X / Iterations;
FP.Y := FP.Y + FV.Y / Iterations;
MinDist := Infinite;
MinIndex := -1;
for J := 0 to Length(FLines) - 1 do
begin
DP := Dist(FP, FLines[J]);
DH := Dist(H, FLines[J]);
if (DP < MinDist) and (DP < DH) then
begin
MinDist := DP;
MinIndex := J;
end;
end;
if MinIndex >= 0 then
if Sqr(MinDist) < 2*Sqr(FBallRadius * 0.7 / 2)
then
begin
MP := MinDistPoint(FP, FLines[MinIndex]);
FV := Mirror(FV, Subtract(MP, FP));
end;
end;
FBallTopLeft.X := Round(FP.X - FBallRadius);
FBallTopLeft.Y := Round(FP.Y - FBallRadius);
Canvas.Brush.Color := clBlue;
Canvas.Ellipse(FBallTopLeft.X, FBallTopLeft.Y,
FBallTopLeft.X + FBallRadius * 2, FBallTopLeft.Y + FBallRadius * 2);
end;
procedure TForm2.Timer1Timer(Sender: TObject);
begin
invalidate;
end;
end.
Every time the key is pressed, you compute the new coordinate of the object after the move would be executed. Then you can test for intersections between the object trajectory and the line in the map.
Since your map can be considered a set of line segments, and given that your object path is linear, you can find all the possible collisions by finding intersections between the object path and the lines on which the segments of your map lie. You will only have two slopes for the object path: zero and infinity. So for each map segment:
Compute its slope. If the map segment slope is the same as object path slope, they will not intersect.
Compute the intersection between the lines that the map segment and the object path are one (see here for instance)
Check if the map segment ends before the collision point: if yes, then no collision
Check if the object path ends before the collision point: if yes, then no collision
If not doing it yourself is OK, you could use ready made library for this task. Box2D has Delphi version here
I had already half-way answered my own question in the question its self. One thing I had thought of was reading the pixels of the image in the direction of the movement, and check if there's a line there or not. I now realize that I can have an extra layer under the FBMap map layer for the background, and leave the map layer as it is with only the collidable walls drawn.
When moving, scan the pixels in the direction of the movement on that particular layer, not the full image. Since I already have a pre-drawn layer sitting there, I can read it rather than the main image. Based on the speed of movement, I only need to look so many pixels ahead (at least a few more pixels than the number of pixels of movement).
Also, in case the background of the image has a picture representing the walls rather than straight plain lines, then this layer doesn't even have to be drawn at all. This layer can be explicitly used just for scanning a few pixels ahead of movement for collision areas. As a matter of fact, since I also need to recognize collision with other moving objects, I can draw all the objects on here as well (in black/white).
A few iterations of pixels across a canvas, for example 20, is nothing compared to extensive iterations through the map lines, for example 2000.

Create a special visual selection tool for Image

I want to create a special kind of selection, in which the image darkened and in part which user is selecting, the real Image is shown. You can see an Example:
I found two approaches for implementing this:
Implementing a control which show the darkened image.
When user drag an ellipse over this control, an ellipse copy the real image (Image which is NOT Darkened) into the control canvas.
In this scenario When he/she try to Resize the ellipse to SMALLER SIZE, first the whole rectangular area of ellipse darkened and then real image draw in the new Smaller Ellipse.
Same as Approach 1, but instead of drawing on the canvas of the control, we create a new control which show the real image. In this case, all messages send to the new control, SHOULD pass to the parent control. Because if user try to resize the ellipse to smaller size, WM_MOVE messages sent to this control, instead of the parent control.
Can please, someone show me the right direction for implementing this. I think that approach 1 is very hard to implement because it cause lot's of Flicker. Unless I implement a way to only repaint the changed part by InvalidateRect function.
Here is the code of the class TScreenEmul which is implemented by me, until now. It works but it has flicker.
unit ScreenEmul;
interface
uses Classes, Types, Windows, Messages, Graphics, Controls, SysUtils, Dialogs, ExtCtrls;
const
PixelCountMax = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..PixelCountMax-1] of TRGBTriple;
TScreenEmul = class(TCustomControl)
private
LastRect, DrawRect: TRect;
DrawStart: TPoint;
MouseDown: Boolean;
Backup, Darken: TBitmap;
FBitmap: TBitmap;
procedure BitmapChange(Sender: TObject);
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd ); message WM_ERASEBKGND;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure DarkenBitmap(B: TBitmap);
procedure RestoreImage;
procedure CalculateDrawRect(X, Y: Integer);
procedure SetBitmap(const Value: TBitmap);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Bitmap: TBitmap read FBitmap write SetBitmap;
end;
implementation
{ TScreenEmul }
function AlphaBlend(Color1, Color2: TRGBTriple; Alpha: Byte): TRGBTriple; overload;
var
rPrimary : Real; // Primary (Color1) Intensity
rSecondary: Real;// Secondary (Color2) Intensity
begin
rPrimary:=((Alpha+1)/$100);
rSecondary:=(($100-Alpha)/$100);
with Result do
begin
rgbtBlue := Trunc(Color1.rgbtBlue * rPrimary + Color2.rgbtBlue * rSecondary);
rgbtGreen := Trunc(Color1.rgbtGreen * rPrimary + Color2.rgbtGreen * rSecondary);
rgbtRed := Trunc(Color1.rgbtRed * rPrimary + Color2.rgbtRed * rSecondary);
end;
end;
procedure TScreenEmul.BitmapChange(Sender: TObject);
begin
FreeAndNil(Backup);
Backup := TBitmap.Create;
Backup.Assign(FBitmap);
DarkenBitmap(FBitmap);
Darken := TBitmap.Create;
Darken.Assign(FBitmap);
end;
procedure TScreenEmul.CalculateDrawRect(X, Y: Integer);
begin
if X >= DrawStart.X then
begin
if DrawRect.Left <> DrawStart.X then DrawRect.Left := DrawStart.X;
DrawRect.Right := X
end
else
begin
if DrawRect.Right <> DrawStart.X then DrawRect.Right := DrawStart.X;
DrawRect.Left := X;
end;
if Y >= DrawStart.Y then
begin
if DrawRect.Top <> DrawStart.Y then DrawRect.Top := DrawStart.Y;
DrawRect.Bottom := Y;
end
else
begin
if DrawRect.Bottom <> DrawStart.Y then DrawRect.Bottom := DrawStart.Y;
DrawRect.Top := Y;
end;
end;
constructor TScreenEmul.Create(AOwner: TComponent);
begin
inherited;
MouseDown := False;
FBitmap := TBitmap.Create;
FBitmap.OnChange := BitmapChange;
DoubleBuffered := True;
end;
procedure TScreenEmul.DarkenBitmap(B: TBitmap);
var
I, J: Integer;
Row: PRGBTripleArray;
rgbBlack: tagRGBTRIPLE;
begin
rgbBlack.rgbtBlue := 0; rgbBlack.rgbtGreen := 0; rgbBlack.rgbtRed := 0;
for I := 0 to B.Height - 1 do
begin
Row := B.ScanLine[I];
for J := 0 to B.Width - 1 do
Row[J] := AlphaBlend(Row[J], rgbBlack, 150);
end;
end;
destructor TScreenEmul.Destroy;
begin
FBitmap.Free;
inherited;
end;
procedure TScreenEmul.RestoreImage;
begin
BitBlt(FBitmap.Canvas.Handle,
LastRect.Left, LastRect.Top, RectWidth(LastRect), RectHeight(LastRect),
Darken.Canvas.Handle, LastRect.Left, LastRect.Top, SRCCOPY);
end;
procedure TScreenEmul.SetBitmap(const Value: TBitmap);
begin
FBitmap := Value;
FBitmap.OnChange := BitmapChange;
end;
procedure TScreenEmul.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := LResult(False);
end;
procedure TScreenEmul.WMLButtonDown(var Message: TWMLButtonDown);
begin
MouseDown := True;
with DrawRect do
begin
Left := Message.XPos;
Top := Message.YPos;
Right := Left;
Bottom := Top;
end;
DrawStart.X := DrawRect.Top;
DrawStart.Y := DrawRect.Left;
end;
procedure TScreenEmul.WMLButtonUp(var Message: TWMLButtonUp);
begin
MouseDown := False;
RestoreImage;
InvalidateRect(Self.Handle, DrawRect, False);
end;
procedure TScreenEmul.WMMouseMove(var Message: TWMMouseMove);
begin
if not MouseDown then Exit;
CalculateDrawRect(Message.XPos, Message.YPos);
RestoreImage;
BitBlt(
FBitmap.Canvas.Handle,
DrawRect.Left, DrawRect.Top, RectWidth(DrawRect), RectHeight(DrawRect),
Backup.Canvas.Handle,
DrawRect.Left, DrawRect.Top,
SRCCOPY);
InvalidateRect(Self.Handle, DrawRect, False);
LastRect := DrawRect;
end;
procedure TScreenEmul.WMPaint(var Message: TWMPaint);
var
B: TBitmap;
Rct: TRect;
X, Y: Integer;
FullRepaint: Boolean;
begin
inherited;
FullRepaint := GetUpdateRect(Self.Handle, Rct, False);
if not FullRepaint then
begin
Canvas.Draw(0, 0, FBitmap);
end
else
begin
B := TBitmap.Create;
B.SetSize(RectWidth(Rct), RectHeight(Rct));
FBitmap.Canvas.CopyRect(Rect(0, 0, B.Width, B.Height), B.Canvas, Rct);
Canvas.Draw(0, 0, B);
FreeAndNil(B);
end;
end;
end.
For using this class:
var
ScreenEmul: TScreenEmul;
begin
ScreenEmul := TScreenEmul.Create(Self);
ScreenEmul.Parent := Self;
ScreenEmul.Align := alClient;
ScreenEmul.Bitmap.LoadFromFile('C:\img13.bmp');
I solved the problem. I answer the question for the record:
1- WMEraseBkgnd should return True to prevent painting background. I mistakenly returned False.
2- I inherited the WMPaint method which is not correct. I also copy the updated Rect into new Bitmap and then draw the bitmap into canvas which was slow the painting process. Here is full fixed source code:
unit ScreenEmul;
interface
uses Classes, Types, Windows, Messages, Graphics, Controls, SysUtils, Dialogs, ExtCtrls;
const
PixelCountMax = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..PixelCountMax-1] of TRGBTriple;
TScreenEmul = class(TCustomControl)
private
LastRect, DrawRect: TRect;
DrawStart: TPoint;
MouseDown: Boolean;
Backup, Darken: TBitmap;
FBitmap: TBitmap;
procedure BitmapChange(Sender: TObject);
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure DarkenBitmap(B: TBitmap);
procedure RestoreImage;
procedure CalculateDrawRect(X, Y: Integer);
procedure SetBitmap(const Value: TBitmap);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Bitmap: TBitmap read FBitmap write SetBitmap;
end;
implementation
{ TScreenEmul }
function AlphaBlend(Color1, Color2: TRGBTriple; Alpha: Byte): TRGBTriple; overload;
var
rPrimary : Real; // Primary (Color1) Intensity
rSecondary: Real;// Secondary (Color2) Intensity
begin
rPrimary:=((Alpha+1)/$100);
rSecondary:=(($100-Alpha)/$100);
with Result do
begin
rgbtBlue := Trunc(Color1.rgbtBlue * rPrimary + Color2.rgbtBlue * rSecondary);
rgbtGreen := Trunc(Color1.rgbtGreen * rPrimary + Color2.rgbtGreen * rSecondary);
rgbtRed := Trunc(Color1.rgbtRed * rPrimary + Color2.rgbtRed * rSecondary);
end;
end;
procedure TScreenEmul.BitmapChange(Sender: TObject);
begin
FreeAndNil(Backup);
Backup := TBitmap.Create;
Backup.Assign(FBitmap);
DarkenBitmap(FBitmap);
Darken := TBitmap.Create;
Darken.Assign(FBitmap);
end;
procedure TScreenEmul.CalculateDrawRect(X, Y: Integer);
begin
if X >= DrawStart.X then
begin
if DrawRect.Left <> DrawStart.X then DrawRect.Left := DrawStart.X;
DrawRect.Right := X
end
else
begin
if DrawRect.Right <> DrawStart.X then DrawRect.Right := DrawStart.X;
DrawRect.Left := X;
end;
if Y >= DrawStart.Y then
begin
if DrawRect.Top <> DrawStart.Y then DrawRect.Top := DrawStart.Y;
DrawRect.Bottom := Y;
end
else
begin
if DrawRect.Bottom <> DrawStart.Y then DrawRect.Bottom := DrawStart.Y;
DrawRect.Top := Y;
end;
end;
constructor TScreenEmul.Create(AOwner: TComponent);
begin
inherited;
MouseDown := False;
FBitmap := TBitmap.Create;
FBitmap.OnChange := BitmapChange;
DoubleBuffered := True;
end;
procedure TScreenEmul.DarkenBitmap(B: TBitmap);
var
I, J: Integer;
Row: PRGBTripleArray;
rgbBlack: tagRGBTRIPLE;
begin
rgbBlack.rgbtBlue := 0; rgbBlack.rgbtGreen := 0; rgbBlack.rgbtRed := 0;
for I := 0 to B.Height - 1 do
begin
Row := B.ScanLine[I];
for J := 0 to B.Width - 1 do
Row[J] := AlphaBlend(Row[J], rgbBlack, 150);
end;
end;
destructor TScreenEmul.Destroy;
begin
FBitmap.Free;
inherited;
end;
procedure TScreenEmul.RestoreImage;
begin
BitBlt(FBitmap.Canvas.Handle,
LastRect.Left, LastRect.Top, RectWidth(LastRect), RectHeight(LastRect),
Darken.Canvas.Handle, LastRect.Left, LastRect.Top, SRCCOPY);
end;
procedure TScreenEmul.SetBitmap(const Value: TBitmap);
begin
FBitmap := Value;
FBitmap.OnChange := BitmapChange;
end;
procedure TScreenEmul.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := LResult(True);
end;
procedure TScreenEmul.WMLButtonDown(var Message: TWMLButtonDown);
begin
MouseDown := True;
with DrawRect do
begin
Left := Message.XPos;
Top := Message.YPos;
Right := Left;
Bottom := Top;
end;
DrawStart.X := DrawRect.Top;
DrawStart.Y := DrawRect.Left;
end;
procedure TScreenEmul.WMLButtonUp(var Message: TWMLButtonUp);
begin
MouseDown := False;
RestoreImage;
InvalidateRect(Self.Handle, DrawRect, False);
end;
procedure TScreenEmul.WMMouseMove(var Message: TWMMouseMove);
begin
if not MouseDown then Exit;
CalculateDrawRect(Message.XPos, Message.YPos);
RestoreImage;
BitBlt(
FBitmap.Canvas.Handle,
DrawRect.Left, DrawRect.Top, RectWidth(DrawRect), RectHeight(DrawRect),
Backup.Canvas.Handle,
DrawRect.Left, DrawRect.Top,
SRCCOPY);
InvalidateRect(Self.Handle, DrawRect, False);
LastRect := DrawRect;
end;
procedure TScreenEmul.WMPaint(var Message: TWMPaint);
var
Rct: TRect;
FullRepaint: Boolean;
begin
FullRepaint := GetUpdateRect(Self.Handle, Rct, False);
if not FullRepaint then
Canvas.Draw(0, 0, FBitmap)
else
BitBlt(Canvas.Handle, Rct.Left, Rct.Top, RectWidth(Rct), RectHeight(Rct), FBitmap.Canvas.Handle, Rct.Left, Rct.Top, SRCCOPY);
end;
end.
I have done someting similar... here are extracts of my code (only one bitmap in memory):
Grab screen ...
Type
GrabScreen = (GTSCREEN);
[...]
procedure PGrabScreen(bm: TBitMap; gt : GrabScreen);
var
DestRect, SourceRect: TRect;
h: THandle;
hdcSrc : THandle;
pt : TPoint;
begin
case(gt) of
//...
GTSCREEN : h := GetDesktopWindow;
end;
if h <> 0 then
begin
try
begin
hdcSrc := GetWindowDC(h);
GetWindowRect(h, SourceRect);
end;
bm.Width := SourceRect.Right - SourceRect.Left;
bm.Height := SourceRect.Bottom - SourceRect.Top;
DestRect := Rect(0, 0, SourceRect.Right - SourceRect.Left, SourceRect.Bottom - SourceRect.Top);
StretchBlt(bm.Canvas.Handle, 0, 0, bm.Width,
bm.Height, hdcSrc,
0,0,SourceRect.Right - SourceRect.Left,
SourceRect.Bottom - SourceRect.Top,
SRCCOPY);
DrawCursor(bm,SourceRect.Left, SourceRect.Top);
finally
ReleaseDC(0, hdcSrc);
end;
end;
end;
Blur that bitmap once selection is initiated by mouse down (suggested code)
procedure BitmapBlur(var theBitmap: TBitmap);
var
x, y: Integer;
yLine,
xLine: PByteArray;
begin
for y := 1 to theBitmap.Height -2 do begin
yLine := theBitmap.ScanLine[y -1];
xLine := theBitmap.ScanLine[y];
for x := 1 to theBitmap.Width -2 do begin
xLine^[x * 3] := (
xLine^[x * 3 -3] + xLine^[x * 3 +3] +
yLine^[x * 3 -3] + yLine^[x * 3 +3] +
yLine^[x * 3] + xLine^[x * 3 -3] +
xLine^[x * 3 +3] + xLine^[x * 3]) div 8;
xLine^[x * 3 +1] := (
xLine^[x * 3 -2] + xLine^[x * 3 +4] +
yLine^[x * 3 -2] + yLine^[x * 3 +4] +
yLine^[x * 3 +1] + xLine^[x * 3 -2] +
xLine^[x * 3 +4] + xLine^[x * 3 +1]) div 8;
xLine^[x * 3 +2] := (
xLine^[x * 3 -1] + xLine^[x * 3 +5] +
yLine^[x * 3 -1] + yLine^[x * 3 +5] +
yLine^[x * 3 +2] + xLine^[x * 3 -1] +
xLine^[x * 3 +5] + xLine^[x * 3 +2]) div 8;
end;
end;
end;
Select area* on the blurred bitmap on screen (exemple:)
procedure GrabSelectedArea(Sender: TObject);
begin
Grab(image1.Picture.Bitmap, GTSCREEN);
bmp := Image1.Picture.Bitmap;
image1.Width := image1.Picture.Bitmap.Width;
image1.Height := image1.Picture.Bitmap.Height;
DoSelect := true;
end;
Doing so, reverse (offset) the blur effect for the selected area on the bitmap.
*Here the code i have for selection
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
DestRect, SourceRect : TRect;
begin
if DoSelect then begin
Image1.Canvas.Rectangle(SelX,SelY,SelX1,SelY1);
if X <= SelX then
begin
SelX1 := SelX;
SelX := X;
end
else
SelX1 := X;
if Y <= SelY then
begin
SelY1 := SelY;
SelY := Y;
end
else
SelY1 := Y;
Image1.Canvas.Pen.Mode := pmCopy;
SourceRect := Rect(SelX,SelY,SelX1,SelY1);
DestRect := Rect(0,0,SelX1-SelX,SelY1-SelY);
Image1.Canvas.CopyRect(DestRect,Image1.Canvas,SourceRect);
Image1.Picture.Bitmap.Height := SelY1-SelY;
Image1.Picture.Bitmap.Width := SelX1-SelX;
Image1.SetBounds(0,0,SelX1-SelX,SelY1-SelY);
DoSelect := false;
if FormIsFullScreen then
RestoreForm;
end;
end;
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if DoSelect then begin
SelX := X;
SelY := Y;
SelX1 := X;
SelY1 := Y;
with Image1.Canvas do
begin // Options shown in comments
Pen.Width := 1; // 2; // use with solid pen style
Pen.Style := psDashDotDot; // psSolid;
Pen.Mode := pmNotXOR; // pmXor;
Brush.Style := bsClear;
Pen.Color := clBlue; // clYellow;
end;
end;
end;
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if DoSelect then begin
if ssLeft in Shift then
begin
Image1.Canvas.Rectangle(SelX,SelY,SelX1,SelY1);
SelX1 := X;
SelY1 := Y;
Image1.Canvas.Rectangle(SelX,SelY,SelX1,SelY1);
end;
end;
end;
first you need to have a Bitmap into memory(hidden) which you manipulate so the "flicker" effect won't appear. Second you need to apply some darken algorithm on the bitmap the you display and copy the selection from original Bitmap to the visible Bitmap.
In other words:
OffsetBitmap(original bitmap) copy to visible Bitmap.
when selection occurs:
apply darken effect to visible Bitmap
copy the selected rectangle from OFFSETBITMAP to the visible bitmap so you will have your selection with original light intensity.
Hope this helps to some degree -- implementing this takes a bit of time which I don't have right now.

Zoom image using delphi

I am working with delphi. I have TImage, to which I assign a bitmap.
imgmain.Picture.Bitmap := bmpMain;
imgmain.Picture.Bitmap.PixelFormat := pf24bit;
imgmain is object of TImage and bmpMain is object of TBitmap
I want to zoom my image. I have one trackbar on my form and as I click on trackbar the image should get zoom. What should I do?
Thank You.
Edit :
I found some solution at here It works but it cut my image.
The code you refer to sets up a transformation from one coordinate space to another, I didn't notice anything that would cut/crop your image there. However, instead of having an inversely proportional zoom factor I'd rather have, easy to understand, linear scaling. Also, I see no reason switching map modes depending on the scaling factor, I would modify the SetCanvasZoomFactor like this;
procedure SetCanvasZoomPercent(Canvas: TCanvas; AZoomPercent: Integer);
begin
SetMapMode(Canvas.Handle, MM_ISOTROPIC);
SetWindowExtEx(Canvas.Handle, 100, 100, nil);
SetViewportExtEx(Canvas.Handle, AZoomPercent, AZoomPercent, nil);
end;
A simplified (no error checking) working example with a bitmap loaded to a TImage, scaled via a TrackBar could be like the below. Note that the above function is inlined in the TrackBar's OnChange event.
type
TForm1 = class(TForm)
imgmain: TImage;
TrackBar1: TTrackBar;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
bmpmain: TBitmap;
[..]
[...]
procedure TForm1.FormCreate(Sender: TObject);
begin
bmpmain := TBitmap.Create;
bmpmain.LoadFromFile(ExtractFilePath('samplebitmap.bmp');
bmpmain.PixelFormat := pf32bit; // No significance, just seems faster here than pf24bit
TrackBar1.Min := 10;
TrackBar1.Max := 200;
TrackBar1.Frequency := 10;
TrackBar1.PageSize := 10;
TrackBar1.Position := 100; // Fires OnChange
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
bmpmain.Free;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
var
Zoom, x, y: Integer;
begin
Zoom := TrackBar1.Position;
if not (Visible or (Zoom = 100)) or (Zoom = 0) then
Exit;
SetMapMode(imgmain.Canvas.Handle, MM_ISOTROPIC);
SetWindowExtEx(imgmain.Canvas.Handle, 100, 100, nil);
SetViewportExtEx(imgmain.Canvas.Handle, Zoom, Zoom, nil);
x := imgmain.Width * 50 div Zoom - bmpmain.Width div 2;
y := imgmain.Height * 50 div Zoom - bmpmain.Height div 2;
imgmain.Canvas.Draw(x, y, bmpmain);
if (x > 0) or (y > 0) then begin
imgmain.Canvas.Brush.Color := clWhite;
ExcludeClipRect(imgmain.Canvas.Handle, x, y, x + bmpmain.Width, y + bmpmain.Height);
imgmain.Canvas.FillRect(imgmain.Canvas.ClipRect);
end;
Label1.Caption := 'Zoom: ' + IntToStr(TrackBar1.Position) + '%';
end;
edit: same code with a TImage in a ScrollBox;
type
TForm1 = class(TForm)
TrackBar1: TTrackBar;
Label1: TLabel;
ScrollBox1: TScrollBox;
imgmain: TImage;
procedure FormCreate(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
bmpmain: TBitmap;
[...]
[...]
const
FULLSCALE = 100;
procedure TForm1.FormCreate(Sender: TObject);
begin
imgmain.Left := 0;
imgmain.Top := 0;
bmpmain := TBitmap.Create;
bmpmain.LoadFromFile(ExtractFilePath(Application.ExeName) + '610x.bmp');
bmpmain.PixelFormat := pf32bit;
TrackBar1.Min := FULLSCALE div 10; // %10
TrackBar1.Max := FULLSCALE * 2; // %200
TrackBar1.PageSize := (TrackBar1.Max - TrackBar1.Min) div 19;
TrackBar1.Frequency := TrackBar1.PageSize;
TrackBar1.Position := FULLSCALE;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
bmpmain.Free;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
var
Zoom: Integer;
begin
Zoom := TrackBar1.Position;
if not (Visible or (Zoom = FULLSCALE)) or (Zoom = 0) then
Exit;
SetMapMode(imgmain.Canvas.Handle, MM_ISOTROPIC);
SetWindowExtEx(imgmain.Canvas.Handle, FULLSCALE, FULLSCALE, nil);
SetViewportExtEx(imgmain.Canvas.Handle, Zoom, Zoom, nil);
imgmain.Width := Round(bmpmain.Width * Zoom / FULLSCALE);
imgmain.Height := Round(bmpmain.Height * Zoom / FULLSCALE);
if Assigned(imgmain.Picture.Graphic) then begin
imgmain.Picture.Graphic.Width := imgmain.Width;
imgmain.Picture.Graphic.Height := imgmain.Height;
end;
imgmain.Canvas.Draw(0, 0, bmpmain);
Label1.Caption := 'Zoom: ' +
IntToStr(Round(TrackBar1.Position / FULLSCALE * 100)) + '%';
end;

Resources