Zoom image using delphi - 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;

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); }

TWinControl.PaintTo does not work well for themed controls with border in D7

I'm trying do this: Is it possible to Alpha Blend a VCL control on a TForm
for drag & drop a panel with controls in it. this answer by #TOndrej works well except that controls like TEdit or TMemo are painted with the default non-themed border.
The result:
My code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, XPMan;
type
TPanel = class(ExtCtrls.TPanel)
protected
function GetDragImages: TDragImageList; override;
end;
TForm1 = class(TForm)
XPManifest1: TXPManifest;
Panel1: TPanel;
Edit1: TEdit;
Button1: TButton;
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure Panel1StartDrag(Sender: TObject;
var DragObject: TDragObject);
private
FDragImages: TDragImageList;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function TPanel.GetDragImages: TDragImageList;
begin
Result := (Owner as TForm1).FDragImages;
end;
type
TControlProc = procedure(Control: TControl);
procedure IterateControls(Control: TControl; Proc: TControlProc);
var
I: Integer;
begin
if Assigned(Control) then
Proc(Control);
if Control is TWinControl then
for I := 0 to TWinControl(Control).ControlCount - 1 do
IterateControls(TWinControl(Control).Controls[I], Proc);
end;
procedure DisplayDragImage(Control: TControl);
begin
Control.ControlStyle := Control.ControlStyle + [csDisplayDragImage];
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FDragImages := nil;
// set display drag image style
IterateControls(Self, DisplayDragImage);
end;
procedure TForm1.Panel1StartDrag(Sender: TObject;
var DragObject: TDragObject);
var
Image: TBitmap;
begin
if not (Sender is TPanel) then
Exit;
Image := TBitmap.Create;
try
Image.PixelFormat := pf32bit;
Image.Width := TControl(Sender).Width;
Image.Height := TControl(Sender).Height;
Image.Canvas.Lock; // must lock the canvas!
TPanel(Sender).PaintTo(Image.Canvas, 0, 0);
Image.Canvas.Unlock;
FDragImages := TDragImageList.Create(nil);
FDragImages.Width := Image.Width;
FDragImages.Height := Image.Height;
FDragImages.SetDragImage(FDragImages.Add(Image, nil), 0, 0);
FDragImages.ShowDragImage;
except
Image.Free;
FreeAndNil(FDragImages);
raise;
end;
end;
end.
I looked into TWinControl.PaintTo but I don't know what to do to make it work. I know it works for newer versions because clearly the image in the answer creates themed border for the Edit1 control that was painted into the bitmap.
What can I do to fix this?
I looked into a newer version of Delphi and made a procedure that works for D7. I'm not sure about copyrights issue here, so if there is a problem I will remove the code.
procedure WinControl_PaintTo(AControl: TWinControl; DC: HDC; X, Y: Integer);
procedure DrawThemeEdge(DC: HDC; var DrawRect: TRect);
var
Details: TThemedElementDetails;
Save: Integer;
begin
Save := SaveDC(DC);
try
with DrawRect do
ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2);
Details := ThemeServices.GetElementDetails(teEditTextNormal);
ThemeServices.DrawElement(DC, Details, DrawRect);
finally
RestoreDC(DC, Save);
end;
InflateRect(DrawRect, -2, -2);
end;
var
I, EdgeFlags, BorderFlags, SaveIndex: Integer;
R: TRect;
LControl: TControl;
begin
with AControl do
begin
ControlState := ControlState + [csPaintCopy];
SaveIndex := SaveDC(DC);
try
MoveWindowOrg(DC, X, Y);
IntersectClipRect(DC, 0, 0, Width, Height);
BorderFlags := 0;
EdgeFlags := 0;
if GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_CLIENTEDGE <> 0 then
begin
EdgeFlags := EDGE_SUNKEN;
BorderFlags := BF_RECT or BF_ADJUST
end else
if GetWindowLong(Handle, GWL_STYLE) and WS_BORDER <> 0 then
begin
EdgeFlags := BDR_OUTER;
BorderFlags := BF_RECT or BF_ADJUST or BF_MONO;
end;
if (EdgeFlags = EDGE_SUNKEN) and ThemeServices.ThemesEnabled and
not ((csDesigning in ComponentState)) then
begin
// Paint borders themed.
SetRect(R, 0, 0, Width, Height);
if csNeedsBorderPaint in ControlStyle then
DrawThemeEdge(DC, R)
else
begin
ControlStyle := ControlStyle + [csNeedsBorderPaint];
DrawThemeEdge(DC, R);
ControlStyle := ControlStyle - [csNeedsBorderPaint];
end;
MoveWindowOrg(DC, R.Left, R.Top);
IntersectClipRect(DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
end
else if BorderFlags <> 0 then
begin
SetRect(R, 0, 0, Width, Height);
DrawEdge(DC, R, EdgeFlags, BorderFlags);
MoveWindowOrg(DC, R.Left, R.Top);
IntersectClipRect(DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
end;
Perform(WM_ERASEBKGND, DC, 0);
Perform(WM_PAINT, DC, 0);
if ControlCount <> 0 then
for I := 0 to ControlCount - 1 do
begin
LControl := Controls[I];
if (LControl is TWinControl) and (LControl.Visible) then
WinControl_PaintTo(TWinControl(LControl), DC, LControl.Left, LControl.Top);
end;
finally
RestoreDC(DC, SaveIndex);
end;
ControlState := ControlState - [csPaintCopy];
end;
end;
Note that even Delphi's implementation does not draw the correct themed border for TEdit and TMemo:
Original panel:
Result with PaintTo:

Delphi, How to make a shape stop moving

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.

Showing a TImage partially Dim

I'm trying to make a cropping tool that will look as follow:
Original Image:
Crop tool - This is what I want:
Notice that the cropping area is showing the original colors, and around the colors are dim.
What I did is to place a TShape over my TImage with properties:
object Shape1: TShape
Brush.Color = clSilver
Pen.Mode = pmMask
Pen.Style = psDot
end
I plan to use the TShape to make the re-sizing/coping control.
This is how it looks in Delphi:
As you can see, it does not looks good (colors palette looks dithered), but the main problem that I need the dim area to be around the crop area, not in the center. I have tried to cover the whole TImage with another TShpae, tried different Pen.Mode combinations but there are no good results, and I think my method/approach is bad.
Do you have any ideas on how to achieve the desired behavior?
a little part is missing here, but should not be a problem to add...
unit Unit3;
// 20121108 by Thomas Wassermann
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, jpeg;
type
TForm3 = class(TForm)
Image1: TImage;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
private
{ Private-Deklarationen }
FDownPoint, FCurrentPoint: TPoint;
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
uses Math;
{$R *.dfm}
procedure TForm3.FormCreate(Sender: TObject);
begin
PaintBox1.BringToFront;
end;
type
pRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = ARRAY [0 .. $EFFFFFF] OF TRGBQuad;
Procedure SetAlpha(bmp: TBitMap; Alpha: Byte; R: TRect);
var
pscanLine32: pRGBQuadArray;
i, j: Integer;
begin
bmp.PixelFormat := pf32Bit;
bmp.HandleType := bmDIB;
bmp.ignorepalette := true;
bmp.alphaformat := afDefined;
for i := 0 to bmp.Height - 1 do
begin
pscanLine32 := bmp.Scanline[i];
for j := 0 to bmp.Width - 1 do
begin
if (j >= R.Left) and (j <= R.Right) and (i >= R.Top) and (i <= R.Bottom) then
begin
pscanLine32[j].rgbReserved := 0;
pscanLine32[j].rgbBlue := 0;
pscanLine32[j].rgbRed := 0;
pscanLine32[j].rgbGreen := 0;
end
else
begin
pscanLine32[j].rgbReserved := Alpha;
pscanLine32[j].rgbBlue := Alpha;
pscanLine32[j].rgbRed := Alpha;
pscanLine32[j].rgbGreen := Alpha;
end;
end;
end;
end;
procedure TForm3.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FDownPoint.X := X;
FDownPoint.Y := Y;
FCurrentPoint := FDownPoint;
PaintBox1.Invalidate;
end;
procedure TForm3.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then
begin
FCurrentPoint.X := X;
FCurrentPoint.Y := Y;
PaintBox1.Invalidate;
end;
end;
procedure TForm3.PaintBox1Paint(Sender: TObject);
var
bmp: TBitMap;
SelRect: TRect;
begin
bmp := TBitMap.Create;
try
bmp.Width := PaintBox1.Width;
bmp.Height := PaintBox1.Height;
if (FCurrentPoint.X = FDownPoint.X) and (FCurrentPoint.Y = FDownPoint.Y) then
SelRect := PaintBox1.BoundsRect
else
begin
SelRect.Left := Min(FCurrentPoint.X, FDownPoint.X);
SelRect.Top := Min(FCurrentPoint.Y, FDownPoint.Y);
SelRect.Right := Max(FCurrentPoint.X, FDownPoint.X);
SelRect.Bottom := Max(FCurrentPoint.Y, FDownPoint.Y);
end;
SetAlpha(bmp, 140, SelRect);
PaintBox1.Canvas.Draw(0, 0, bmp);
finally
bmp.Free;
end;
end;
end.
The attempt on this solution is to use a overlying paintbox, same clientrect as the image, for all the drawing and selection. By using the coordinates generated by mouse/down/move a semitransparent bitmap is created, which is full transparent in the selected rect. After generation it's painted on the paintbox. Further paintings could be done there e.g. frames, anchors, crosshair. Any user action would have to be caught in mousedown, depending of the selected part ,e.g. an anchor a sizing of the rect could be done.
Usually I'd prefer GDI+ for requests like this, but as shown, no additional units are required. Source: http://www.bummisoft.de/download/transparenteauswahl.zip

What is the best way to make a Delphi Application completely full screen?

What is the best way to make a delphi application (delphi 2007 for win32 here) go completely full screen, removing the application border and covering windows task bar ?
I am looking for something similar to what IE does when you hit F11.
I wish this to be a run time option for the user not a design time decision by my good self.
As Mentioned in the accepted answer
BorderStyle := bsNone;
was part of the way to do it. Strangely I kept getting a E2010 Incompatible types: 'TFormBorderStyle' and 'TBackGroundSymbol' error when using that line (another type had bsNone defined).
To overcome this I had to use :
BorderStyle := Forms.bsNone;
Well, this has always worked for me. Seems a bit simpler...
procedure TForm52.Button1Click(Sender: TObject);
begin
BorderStyle := bsNone;
WindowState := wsMaximized;
end;
A Google search turned up the following, additional methods:
(though I think I'd try Roddy's method first)
Manually fill the screen (from: About Delphi)
procedure TSomeForm.FormShow(Sender: TObject) ;
var
r : TRect;
begin
Borderstyle := bsNone;
SystemParametersInfo
(SPI_GETWORKAREA, 0, #r,0) ;
SetBounds
(r.Left, r.Top, r.Right-r.Left, r.Bottom-r.Top) ;
end;
Variation on a theme by Roddy
FormStyle := fsStayOnTop;
BorderStyle := bsNone;
Left := 0;
Top := 0;
Width := Screen.Width;
Height := Screen.Height;
The WinAPI way (by Peter Below from TeamB)
private // in form declaration
Procedure WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
Procedure TForm1.WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
Begin
inherited;
With msg.MinMaxInfo^.ptMaxTrackSize Do Begin
X := GetDeviceCaps( Canvas.handle, HORZRES ) + (Width - ClientWidth);
Y := GetDeviceCaps( Canvas.handle, VERTRES ) + (Height - ClientHeight
);
End;
End;
procedure TForm1.Button2Click(Sender: TObject);
Const
Rect: TRect = (Left:0; Top:0; Right:0; Bottom:0);
FullScreen: Boolean = False;
begin
FullScreen := not FullScreen;
If FullScreen Then Begin
Rect := BoundsRect;
SetBounds(
Left - ClientOrigin.X,
Top - ClientOrigin.Y,
GetDeviceCaps( Canvas.handle, HORZRES ) + (Width - ClientWidth),
GetDeviceCaps( Canvas.handle, VERTRES ) + (Height - ClientHeight ));
// Label2.caption := IntToStr(GetDeviceCaps( Canvas.handle, VERTRES ));
End
Else
BoundsRect := Rect;
end;
Maximize the form and hide the title bar. The maximize line is done from memory, but I'm pretty sure WindowState is the property you want.
There's also this article, but that seems too complicated to me.
procedure TForm1.FormCreate(Sender: TObject) ;
begin
//maximize the window
WindowState := wsMaximized;
//hide the title bar
SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
ClientHeight := Height;
end;
Edit: Here's a complete example, with "full screen" and "restore" options. I've broken out the different parts into little procedures for maximum clarity, so this could be greatly compressed into just a few lines.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
btnGoFullScreen: TButton;
btnNotFullScreen: TButton;
btnShowTitleBar: TButton;
btnHideTitleBar: TButton;
btnQuit: TButton;
procedure btnGoFullScreenClick(Sender: TObject);
procedure btnShowTitleBarClick(Sender: TObject);
procedure btnHideTitleBarClick(Sender: TObject);
procedure btnNotFullScreenClick(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
private
SavedLeft : integer;
SavedTop : integer;
SavedWidth : integer;
SavedHeight : integer;
SavedWindowState : TWindowState;
procedure FullScreen;
procedure NotFullScreen;
procedure SavePosition;
procedure HideTitleBar;
procedure ShowTitleBar;
procedure RestorePosition;
procedure MaximizeWindow;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btnQuitClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm1.btnGoFullScreenClick(Sender: TObject);
begin
FullScreen;
end;
procedure TForm1.btnNotFullScreenClick(Sender: TObject);
begin
NotFullScreen;
end;
procedure TForm1.btnShowTitleBarClick(Sender: TObject);
begin
ShowTitleBar;
end;
procedure TForm1.btnHideTitleBarClick(Sender: TObject);
begin
HideTitleBar;
end;
procedure TForm1.FullScreen;
begin
SavePosition;
HideTitleBar;
MaximizeWindow;
end;
procedure TForm1.HideTitleBar;
begin
SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
ClientHeight := Height;
end;
procedure TForm1.MaximizeWindow;
begin
WindowState := wsMaximized;
end;
procedure TForm1.NotFullScreen;
begin
RestorePosition;
ShowTitleBar;
end;
procedure TForm1.RestorePosition;
begin
//this proc uses what we saved in "SavePosition"
WindowState := SavedWindowState;
Top := SavedTop;
Left := SavedLeft;
Width := SavedWidth;
Height := SavedHeight;
end;
procedure TForm1.SavePosition;
begin
SavedLeft := Left;
SavedHeight := Height;
SavedTop := Top;
SavedWidth := Width;
SavedWindowState := WindowState;
end;
procedure TForm1.ShowTitleBar;
begin
SetWindowLong(Handle,gwl_Style,GetWindowLong(Handle,gwl_Style) or ws_Caption or ws_border);
Height := Height + GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end.
Put to the form onShow event such code:
WindowState:=wsMaximized;
And to the OnCanResize this:
if (newwidth<width) and (newheight<height) then
Resize:=false;
How to constrain a sub-form within the Mainform like it was an MDI app., but without the headaches! (Note: The replies on this page helped me get this working, so that's why I posted my solution here)
private
{ Private declarations }
StickyAt: Word;
procedure WMWINDOWPOSCHANGING(Var Msg: TWMWINDOWPOSCHANGING); Message M_WINDOWPOSCHANGING;
Procedure WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
later...
procedure TForm2.WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
var
A, B: Integer;
iFrameSize: Integer;
iCaptionHeight: Integer;
iMenuHeight: Integer;
begin
iFrameSize := GetSystemMetrics(SM_CYFIXEDFRAME);
iCaptionHeight := GetSystemMetrics(SM_CYCAPTION);
iMenuHeight := GetSystemMetrics(SM_CYMENU);
// inside the Mainform client area
A := Application.MainForm.Left + iFrameSize;
B := Application.MainForm.Top + iFrameSize + iCaptionHeight + iMenuHeight;
with Msg.WindowPos^ do
begin
if x <= A + StickyAt then
x := A;
if x + cx >= A + Application.MainForm.ClientWidth - StickyAt then
x := (A + Application.MainForm.ClientWidth) - cx + 1;
if y <= B + StickyAt then
y := B;
if y + cy >= B + Application.MainForm.ClientHeight - StickyAt then
y := (B + Application.MainForm.ClientHeight) - cy + 1;
end;
end;
and yet more...
Procedure TForm2.WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
var
iFrameSize: Integer;
iCaptionHeight: Integer;
iMenuHeight: Integer;
Begin
inherited;
iFrameSize := GetSystemMetrics(SM_CYFIXEDFRAME);
iCaptionHeight := GetSystemMetrics(SM_CYCAPTION);
iMenuHeight := GetSystemMetrics(SM_CYMENU);
With msg.MinMaxInfo^.ptMaxPosition Do
begin
// position of top when maximised
X := Application.MainForm.Left + iFrameSize + 1;
Y := Application.MainForm.Top + iFrameSize + iCaptionHeight + iMenuHeight + 1;
end;
With msg.MinMaxInfo^.ptMaxSize Do
Begin
// width and height when maximized
X := Application.MainForm.ClientWidth;
Y := Application.MainForm.ClientHeight;
End;
With msg.MinMaxInfo^.ptMaxTrackSize Do
Begin
// maximum size when maximised
X := Application.MainForm.ClientWidth;
Y := Application.MainForm.ClientHeight;
End;
// to do: minimum size (maybe)
End;
In my case, the only working solution is:
procedure TFormHelper.FullScreenMode;
begin
BorderStyle := bsNone;
ShowWindowAsync(Handle, SW_MAXIMIZE);
end;
You need to make sure Form position is poDefaultPosOnly.
Form1.Position := poDefaultPosOnly;
Form1.FormStyle := fsStayOnTop;
Form1.BorderStyle := bsNone;
Form1.Left := 0;
Form1.Top := 0;
Form1.Width := Screen.Width;
Form1.Height := Screen.Height;
Tested and works on Win7 x64.
Try:
Align = alClient
FormStyle = fsStayOnTop
This always align to the primary monitor;
Hm. Looking at the responses I seem to remember dealing with this about 8 years ago when I coded a game. To make debugging easier, I used the device-context of a normal, Delphi form as the source for a fullscreen display.
The point being, that DirectX is capable of running any device context fullscreen - including the one allocated by your form.
So to give an app "true" fullscreen capabilities, track down a DirectX library for Delphi and it will probably contain what you need out of the box.

Resources