I have a TImage component in a ScrollBox, where the image is larger than the ScrollBox. I can use the scroll bars to move the image around in the ScrollBox, but I want to use the mouse. I want to click on the image and drag it to move it in the ScrollBox. As I do this, the ScrollBox's scroll bars should move correspondingly.
I am going to set the image cursor to crHandPoint so that people will expect that they can move the image around.
My question is, how do I make this work?
procedure TfrmKaarte.imgKaartCanvasMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
bPanning:=True;
pt := Mouse.CursorPos;
end;
procedure TfrmKaarte.imgKaartCanvasMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if bPanning=True then
begin
imgKaartCanvas.Left:=X+imgKaartCanvas.Left-pt.X;
imgKaartCanvas.Top:=Y+imgKaartCanvas.Top-pt.Y;
end;
end;
procedure TfrmKaarte.imgKaartCanvasMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
bPanning:=False;
end;
Related
In the TImageViewer control, the user can zoom or pan the picture.
My question is, when the user clicks on the picture, how to get the user's click position on the picture? Especially after the user can zoom in, zoom out or pan the picture, how to get the corresponding picture click position?
As shown below:
How to know whether the user clicked on the battery position?
Demo Project:
Demo source code
I didn't test but it should work:
procedure TfmMain.ivImageViewerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
var
DX, DY: Single;
ImageX, ImageY: Single;
begin
if ivImageViewer.Bitmap.Width * ScalePicture >= ivImageViewer.Width then
DX = ivImageViewer.ViewportPosition.X
else
DX := (ivImageViewer.Bitmap.Width * ScalePicture - ivImageViewer.Width)/2;
ImageX := (X + DX) / ScalePicture;
if ivImageViewer.Bitmap.Height * ScalePicture >= ivImageViewer.Height then
DY = ivImageViewer.ViewportPosition.Y
else
DY := (ivImageViewer.Bitmap.Height * ScalePicture - ivImageViewer.Height)/2;
ImageY := (Y + DY) / ScalePicture;
end;
ImageX and ImageY are the coordinates relative to the original (unscaled) image.
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;
I'm not sure how to explain this so I made an image which will help explaining the situation.
In this image the big black rectangle is my screen. and the amazing art you see is my wallpaper.
The green rectangle is my own application which is a transparent form.
I want to be able to copy the red rectangle and use it to do some stuff with like moving it to another location.
What I thought that was happening is that whatever is under my form was drawn on the canvas so I could just grab the rectangle from my canvas and save it as an image. Sadly it doesn't work like that.
Can anyone point me in the right direction?
Thanks in advance.
An easy way to aceive this would be to work with UpdateLayeredWindow
using a semitransparent Bitmap with at least a value off 1 in the AlphaCannel to be able to catch mousevents easily. To make the window visible in the example I took a value of 10.
Usually I would take a GDI+ library to paint on the Bitmap, in the example here I tried to reach the goal with usual GDI routined an manipulation off the Alphacannel of the bitmap.
We keep two positions for MouseDown, depending on the button pressed to be able to implement diffent behaviour for the Left and the right mouse button.
As implemented here the left button would be used for painting, the right on for moving the window.
A keypress of enter, caught due to KeyPreview=true, will calculate the coordinates depending on Left/Top and the selection and copy the content using Bitblt.
unit Unit7;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm7 = class(TForm)
procedure FormPaint(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
private
{ Private-Deklarationen }
FDOWN: Boolean;
FMDX: Integer;
FMDY: Integer;
FStartX: Integer;
FStartY: Integer;
FEndX: Integer;
FEndY: Integer;
procedure GenSnapShot;
// procedure WMNCHitTest(var Message: TWMNCHitTest);message WM_NCHitTest;
public
{ Public-Deklarationen }
end;
var
Form7: TForm7;
implementation
{$R *.dfm}
type
pRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = ARRAY [0 .. 0] OF TRGBQuad;
Procedure SetAlpha4Red(bmp: TBitMap);
var
pscanLine32: pRGBQuadArray;
i, j: Integer;
begin
for i := 0 to bmp.Height - 1 do
begin
pscanLine32 := bmp.Scanline[i];
for j := 0 to bmp.Width - 1 do
begin
if pscanLine32[j].rgbRed = 255 then
pscanLine32[j].rgbReserved := 255 // make red opaque
else
pscanLine32[j].rgbReserved := 10; // anything else transparent
end;
end;
end;
procedure TForm7.FormCreate(Sender: TObject);
begin
BorderStyle := bsNone;
KeyPreview := true;
end;
procedure TForm7.GenSnapShot;
var
DC: HDC;
BMP:TBitmap;
begin
DC := GetDC(0);
BMP:=TBitmap.Create;
try
BMP.Width := FEndX - FStartX;
BMP.Height := FEndY - FStartY;
Visible := false; // hide our window
BitBlt(BMP.Canvas.Handle,0,0,BMP.Width,BMP.Height,DC,Left + FStartX, Top + FStartY,srcCopy);
BMP.SaveToFile('C:\temp\Test.bmp'); // hardcoded for testing
finally
Visible := true;
ReleaseDC(0, DC);
BMP.Free;
end;
end;
procedure TForm7.FormKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then
GenSnapShot;
end;
procedure TForm7.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then
begin
FDOWN := true;
FStartX := X;
FStartY := Y;
end
else if ssRight in Shift then
begin
FMDX := X;
FMDY := Y;
end;
end;
procedure TForm7.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then
begin
FEndX := X;
FEndY := Y;
Invalidate;
end
else if ssRight in Shift then
begin
Left := Left + X - FMDX;
Top := Top + Y - FMDY;
end;
end;
procedure TForm7.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FDOWN := False;
Invalidate;
end;
procedure TForm7.FormPaint(Sender: TObject);
const
C_Alpha = 1;
var
DestPoint, srcPoint: TPoint;
winSize: TSize;
DC: HDC;
blendfunc: BLENDFUNCTION;
Owner: HWnd;
curWinStyle: Integer;
exStyle: Dword;
BackImage: TBitMap;
xx, yy: Integer;
begin
DC := GetDC(0);
BackImage := TBitMap.Create;
BackImage.PixelFormat := pf32Bit;
BackImage.Width := Width;
BackImage.Height := Height;
BackImage.Canvas.Brush.Color := clBlack;
BackImage.Canvas.FillRect(Rect(0, 0, Width, Height));
BackImage.Canvas.Pen.Color := clRed;
// if FDown then
begin
if FStartX > FEndX then
xx := FEndX
else
xx := FStartX;
if FStartY > FEndY then
yy := FEndY
else
yy := FStartY;
Canvas.Brush.Style := bsClear;
BackImage.Canvas.Rectangle(xx, yy, FEndX, FEndY);
SetAlpha4Red(BackImage);
end;
try
winSize.cx := Width;
winSize.cy := Height;
srcPoint.X := 0;
srcPoint.Y := 0;
DestPoint := BoundsRect.TopLeft;
exStyle := GetWindowLongA(handle, GWL_EXSTYLE);
if (exStyle and WS_EX_LAYERED = 0) then
SetWindowLong(handle, GWL_EXSTYLE, (exStyle or WS_EX_LAYERED));
With blendfunc do
begin
AlphaFormat := 1;
BlendFlags := 0;
BlendOp := AC_SRC_OVER;
SourceConstantAlpha := 255 - C_Alpha;
end;
UpdateLayeredWindow(handle, DC, #DestPoint, #winSize, BackImage.Canvas.handle, #srcPoint, clBlack, #blendfunc, 2);
finally
ReleaseDC(0, DC);
BackImage.Free;
end;
end;
end.
Program in action:
and the captured result:
I like to create a smooth slowing scroll effect after panning an image in a scrollbox. Just like panning the map in maps.google.com. I'm not sure what type it is, but exactly same behaviour: when dragging the map around with a fast move, it doesn't stop immediately when you release the mouse, but it starts slowing down.
Any ideas, components, links or samples?
The idea:
As per your comment, it should feel like Google Maps and thus while dragging the image, the image should stick to the mouse pointer; no special effects required so far. But at releasing the mouse button, the image needs to move (the scroll box needs to pan) further in the same direction and with a gradually easing speed, starting with the dragging velocity at the moment the mouse button was released.
So we need:
a drag handler for when the mouse is pressed: OnMouseMove will work,
the panning speed at the moment the mouse is released: during the drag operation, we will track the latest speed with a timer,
something that still moves the image after the mouse release: we use the same timer,
a way to update the GUI: updating the image position, scrolling the scroll box and updating the scroll bar positions. Luckily, setting the position of the scroll bars of the scroll box will do all that,
a function to gradually decrease the speed after mouse release. I chose for a simple linear factor, but you can experiment with that.
Setup:
Drop a TScrollBox on your form, create event handlers for OnMouseDown, OnMouseMove and OnMouseUp and set the DoubleBuffered property to True (this needs to be done runtime),
Drop a TTimer on your form, set its interval to 15 milliseconds (~ 67 Hz refresh rate) and create an event handler for OnTimer,
Drop a TImage on the scroll box, load a picture, set the size to something big (e.g. 3200 x 3200), set Stretch to True and set Enabled to False to let the mouse events through to the scroll box.
Code (for scroll box):
unit Unit1;
interface
uses
Windows, SysUtils, Classes, Controls, Forms, JPEG, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
ScrollBox: TScrollBox;
Image: TImage;
TrackingTimer: TTimer;
procedure ScrollBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ScrollBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ScrollBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TrackingTimerTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FDragging: Boolean;
FPrevScrollPos: TPoint;
FPrevTick: Cardinal;
FSpeedX: Single;
FSpeedY: Single;
FStartPos: TPoint;
function GetScrollPos: TPoint;
procedure SetScrollPos(const Value: TPoint);
public
property ScrollPos: TPoint read GetScrollPos write SetScrollPos;
end;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
ScrollBox.DoubleBuffered := True;
end;
function TForm1.GetScrollPos: TPoint;
begin
with ScrollBox do
Result := Point(HorzScrollBar.Position, VertScrollBar.Position);
end;
procedure TForm1.ScrollBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := True;
FPrevTick := GetTickCount;
FPrevScrollPos := ScrollPos;
TrackingTimer.Enabled := True;
FStartPos := Point(ScrollPos.X + X, ScrollPos.Y + Y);
Screen.Cursor := crHandPoint;
end;
procedure TForm1.ScrollBoxMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if FDragging then
ScrollPos := Point(FStartPos.X - X, FStartPos.Y - Y);
end;
procedure TForm1.ScrollBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := False;
Screen.Cursor := crDefault;
end;
procedure TForm1.SetScrollPos(const Value: TPoint);
begin
ScrollBox.HorzScrollBar.Position := Value.X;
ScrollBox.VertScrollBar.Position := Value.Y;
end;
procedure TForm1.TrackingTimerTimer(Sender: TObject);
var
Delay: Cardinal;
begin
Delay := GetTickCount - FPrevTick;
if FDragging then
begin
if Delay = 0 then
Delay := 1;
FSpeedX := (ScrollPos.X - FPrevScrollPos.X) / Delay;
FSpeedY := (ScrollPos.Y - FPrevScrollPos.Y) / Delay;
end
else
begin
if (Abs(FSpeedX) < 0.005) and (Abs(FSpeedY) < 0.005) then
TrackingTimer.Enabled := False
else
begin
ScrollPos := Point(FPrevScrollPos.X + Round(Delay * FSpeedX),
FPrevScrollPos.Y + Round(Delay * FSpeedY));
FSpeedX := 0.83 * FSpeedX;
FSpeedY := 0.83 * FSpeedY;
end;
end;
FPrevScrollPos := ScrollPos;
FPrevTick := GetTickCount;
end;
end.
Code (for panel):
And in case you do not want the scroll bars then use the following code. The example uses a panel as container, but that could be any windowed control or the form itself.
unit Unit2;
interface
uses
Windows, SysUtils, Classes, Controls, Forms, JPEG, ExtCtrls, Math;
type
TForm2 = class(TForm)
Panel: TPanel;
Image: TImage;
TrackingTimer: TTimer;
procedure PanelMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PanelMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure PanelMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TrackingTimerTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FDragging: Boolean;
FPrevImagePos: TPoint;
FPrevTick: Cardinal;
FSpeedX: Single;
FSpeedY: Single;
FStartPos: TPoint;
function GetImagePos: TPoint;
procedure SetImagePos(Value: TPoint);
public
property ImagePos: TPoint read GetImagePos write SetImagePos;
end;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
begin
Panel.DoubleBuffered := True;
end;
function TForm2.GetImagePos: TPoint;
begin
Result.X := Image.Left;
Result.Y := Image.Top;
end;
procedure TForm2.PanelMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := True;
FPrevTick := GetTickCount;
FPrevImagePos := ImagePos;
TrackingTimer.Enabled := True;
FStartPos := Point(X - Image.Left, Y - Image.Top);
Screen.Cursor := crHandPoint;
end;
procedure TForm2.PanelMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
ImagePos := Point(X - FStartPos.X, Y - FStartPos.Y);
end;
procedure TForm2.PanelMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := False;
Screen.Cursor := crDefault;
end;
procedure TForm2.SetImagePos(Value: TPoint);
begin
Value.X := Max(Panel.ClientWidth - Image.Width, Min(0, Value.X));
Value.Y := Max(Panel.ClientHeight - Image.Height, Min(0, Value.Y));
Image.SetBounds(Value.X, Value.Y, Image.Width, Image.Height);
end;
procedure TForm2.TrackingTimerTimer(Sender: TObject);
var
Delay: Cardinal;
begin
Delay := GetTickCount - FPrevTick;
if FDragging then
begin
if Delay = 0 then
Delay := 1;
FSpeedX := (ImagePos.X - FPrevImagePos.X) / Delay;
FSpeedY := (ImagePos.Y - FPrevImagePos.Y) / Delay;
end
else
begin
if (Abs(FSpeedX) < 0.005) and (Abs(FSpeedY) < 0.005) then
TrackingTimer.Enabled := False
else
begin
ImagePos := Point(FPrevImagePos.X + Round(Delay * FSpeedX),
FPrevImagePos.Y + Round(Delay * FSpeedY));
FSpeedX := 0.83 * FSpeedX;
FSpeedY := 0.83 * FSpeedY;
end;
end;
FPrevImagePos := ImagePos;
FPrevTick := GetTickCount;
end;
end.
Code (for paint box):
And when the image's dimensions are limitless (e.g. a globe), you can use a paint box to glue the image's ends together.
unit Unit3;
interface
uses
Windows, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls, JPEG;
type
TForm3 = class(TForm)
Painter: TPaintBox;
Tracker: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PainterMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PainterMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure PainterMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PainterPaint(Sender: TObject);
procedure TrackerTimer(Sender: TObject);
private
FDragging: Boolean;
FGraphic: TGraphic;
FOffset: Integer;
FPrevOffset: Integer;
FPrevTick: Cardinal;
FSpeed: Single;
FStart: Integer;
procedure SetOffset(Value: Integer);
public
property Offset: Integer read FOffset write SetOffset;
end;
implementation
{$R *.dfm}
procedure TForm3.FormCreate(Sender: TObject);
begin
DoubleBuffered := True;
FGraphic := TJPEGImage.Create;
FGraphic.LoadFromFile('gda_world_map_small.jpg');
Constraints.MaxWidth := FGraphic.Width + 30;
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
FGraphic.Free;
end;
procedure TForm3.PainterMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := True;
FPrevTick := GetTickCount;
FPrevOffset := Offset;
Tracker.Enabled := True;
FStart := X - FOffset;
Screen.Cursor := crHandPoint;
end;
procedure TForm3.PainterMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
Offset := X - FStart;
end;
procedure TForm3.PainterMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := False;
Screen.Cursor := crDefault;
end;
procedure TForm3.PainterPaint(Sender: TObject);
begin
Painter.Canvas.Draw(FOffset, 0, FGraphic);
Painter.Canvas.Draw(FOffset + FGraphic.Width, 0, FGraphic);
end;
procedure TForm3.SetOffset(Value: Integer);
begin
FOffset := Value;
if FOffset < -FGraphic.Width then
begin
Inc(FOffset, FGraphic.Width);
Dec(FStart, FGraphic.Width);
end
else if FOffset > 0 then
begin
Dec(FOffset, FGraphic.Width);
Inc(FStart, FGraphic.Width);
end;
Painter.Invalidate;
end;
procedure TForm3.TrackerTimer(Sender: TObject);
var
Delay: Cardinal;
begin
Delay := GetTickCount - FPrevTick;
if FDragging then
begin
if Delay = 0 then
Delay := 1;
FSpeed := (Offset - FPrevOffset) / Delay;
end
else
begin
if Abs(FSpeed) < 0.005 then
Tracker.Enabled := False
else
begin
Offset := FPrevOffset + Round(Delay * FSpeed);
FSpeed := 0.83 * FSpeed;
end;
end;
FPrevOffset := Offset;
FPrevTick := GetTickCount;
end;
end.
In the MouseClickDown event save the X and Y coordinate of mouse cursor in some global variable.
In the MouseMove event calculate the DeltaX = SavedX - CurrentX and the DeltaY = SavedY - CurrentY values.
Then scroll your map/image/panel by DeltaX/DeltaY as an absolute value respect your map/image/panel starting position.
In the MouseClickUp event, use the last calculated DeltaX and DeltaY to set the new starting position of your map/image/panel (essentially leaving it where it is) and reset the SavedX and SavedY values.
You'll need to check for maximum scrolling position, for border, for what happen when the mouse cursor go outside the application....
Does anyone know a way of cropping, scaling and centering an image (jpg or bitmap) using Delphi?
I have an image with large resolution. I would like to be able to scale it to a lower resolution. The ratio of the target resolution may be different from the original image. I want to keep the original photo aspect ratio, therefore, I don't want to stretch to the new resolution, but crop and center it, to fit best and loose minimal data from the original image. Does anyone know how can it be done using Delphi?
I'm guessing that you want to resize to fill the target image edge to edge, and crop the part that goes out of bounds.
Here's pseudocode. The implementation will differ depending on what you're working with.
// Calculate aspect ratios
sourceAspectRatio := souceImage.Width / sourceImage.Height;
targetAspectRatio := targetImage.Width / targetImage.Height;
if (sourceAspectRatio > targetAspectRatio) then
begin
// Target image is narrower, so crop left and right
// Resize source image
sourceImage.Height := targetImage.Height;
// Crop source image
..
end
else
begin
// Target image is wider, so crop top and bottom
// Resize source image
sourceImage.Width := targetImage.Width;
// Crop source image
..
end;
Only answering the math part of your question here. Please ask a separate question about keeping maximum image quality.
You need to determine the scale in which to draw the image, as well as the position. I suggest you try this routine:
function CropRect(const Dest: TRect; SrcWidth, SrcHeight: Integer): TRect;
var
W: Integer;
H: Integer;
Scale: Single;
Offset: TPoint;
begin
W := Dest.Right - Dest.Left;
H := Dest.Bottom - Dest.Top;
Scale := Max(W / SrcWidth, H / SrcHeight);
Offset.X := (W - Round(SrcWidth * Scale)) div 2;
Offset.Y := (H - Round(SrcHeight * Scale)) div 2;
with Dest do
Result := Rect(Left + Offset.X, Top + Offset.Y, Right - Offset.X,
Bottom - Offset.Y);
end;
And a sample calling code:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormResize(Sender: TObject);
private
FGraphic: TGraphic;
end;
implementation
{$R *.dfm}
uses
Jpeg, Math, MyUtils;
procedure TForm1.FormCreate(Sender: TObject);
begin
FGraphic := TJPEGImage.Create;
FGraphic.LoadFromFile('MonaLisa.jpg');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FGraphic.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
R: TRect;
begin
R := CropRect(ClientRect, FGraphic.Width, FGraphic.Height);
Canvas.StretchDraw(R, FGraphic);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
Invalidate;
end;