Related
Program use on touch screen Windows-tablet. Have a grid, where we need to select some cells in a row: target cursor over cell, click left button of mouse, holding it, pull the mouse to the side, and then release left button of mouse (at the same time code in OnDrawCell is drawing cells).
By mouse or by touchpad of notebook works very well. But on tablet's touchscreen doesn't work at all.
I use TDrawGrid and OnMouseDown, OnMouseMove, OnMouseUp events.
In Shift use all options: ssLeft, ssTouch, ssPen. Look at full code:
procedure TfmMain.GridMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ACol, ARow: Integer;
ARect: TRect;
begin
(Sender as TDrawGrid).MouseToCell(X, Y, ACol, ARow);
ARect := (Sender as TDrawGrid).CellRect(ACol, ARow);
pmIsLeft := X<(ARect.Left+((ARect.Right-ARect.Left) div 2));
pmCol := ACol;
pmRow := ARow;
if (ssLeft in Shift) or (ssTouch in Shift) or (ssPen in Shift) then
begin
ChooseDaysInGridRowIndex := ARow;
SetLength(ChooseDays, 0);
end;
end;
procedure TfmMain.GridMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
ACol, ARow: Integer;
begin
if (ssLeft in Shift) or (ssTouch in Shift) or (ssPen in Shift) then
begin
(Sender as TDrawGrid).MouseToCell(X, Y, ACol, ARow);
if (ChooseDaysInGridRowIndex>0) and
(ChooseDaysInGridRowIndex<=(Sender as TDrawGrid).RowCount-1) and
((PagesDays[pagesBuildings.ActivePageIndex][ARow, ACol][0].ReservID<=0) or
((Length(ChooseDays)=0) and ((PagesDays[pagesBuildings.ActivePageIndex][ARow, ACol][1].ReservID<=0)))) then
begin
SetLength(ChooseDays, Length(ChooseDays)+1);
ChooseDays[High(ChooseDays)] := Point(ACol, ChooseDaysInGridRowIndex);
InvalidateRect((Sender as TDrawGrid).Handle,
(Sender as TDrawGrid).CellRect(ACol, ARow),
True);
end;
ChooseDaysInGrid := True;
end;
end;
procedure TfmMain.GridMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ACol, ARow: Integer;
begin
if ChooseDaysInGrid then
begin
(Sender as TDrawGrid).MouseToCell(X, Y, ACol, ARow);
ChooseDaysInGrid := False;
fmGuestArrival.roomID := GridRowTitles[(Sender as TDrawGrid).Tag] [ARow].RoomID;
// Integer((Sender as TDrawGrid).Objects[0, ARow]);
if Length(ChooseDays)>0 then
begin
fmGuestArrival.dateArrival.DateTime :=
IncDay(StartDatePeriod, ChooseDays[0].X-1);
if Length(ChooseDays)>1 then
begin
fmGuestArrival.dateDeparture.DateTime :=
IncDay(StartDatePeriod, ChooseDays[High(ChooseDays)].X - 1);
end
else
begin
fmGuestArrival.dateDeparture.DateTime :=
IncDay(fmGuestArrival.dateArrival.DateTime, 1);
end;
end;
fmGuestArrival.IsEditing := False;
fmGuestArrival.cbStatus.ItemIndex := 0;
fmGuestArrival.ShowModal;
end;
end;
Add Gesturing support by adding a TGestureManager (GestureManager1). Then assign GestureManager1 to the Touch.GestureManager property of the TDrawGrid. Open Touch.Gestures.Standard property of the TDrawGrid and select the gestures you want to be notified of. Create an OnGesture event and add code as needed.
The details are documented by Embarcadero
I have a ImgView32, that is anchored to all form margins. The form is maximized.
The bitmap of ImgView is not fixed (it can be of different sizes)
I am trying to draw a line on a transparent layer using ther code from this question:Drawing lines on layer
Now the problem is that, using that exact code, I can only draw in the top-left corner, like in this image:
As you can observe, the lines can be drawn only in the left top corner.
If I try to add some value to the Start and End Points, the whole thing goes crazy. So I must find a way to translate the points in such a fashion that, the user will be able to draw only inside of the center rect (visible in the image)
I am out of ideas.
Please help
Here is the whole unit:
unit MainU;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,GR32, GR32_Image, GR32_Layers, GR32_Backends, GR32_PNG, StdCtrls,
ExtCtrls;
type
TForm5 = class(TForm)
ImgView: TImgView32;
Button1: TButton;
Memo: TMemo;
Edit3: TEdit;
Button2: TButton;
RadioGroup1: TRadioGroup;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
procedure ImgViewResize(Sender: TObject);
private
{ Private declarations }
FStartPoint, FEndPoint: TPoint;
FDrawingLine: boolean;
bm32: TBitmap32;
BL : TBitmapLayer;
FSelection: TPositionedLayer;
public
{ Public declarations }
procedure AddLineToLayer;
procedure AddCircleToLayer;
procedure SwapBuffers32;
procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
procedure LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
procedure SetSelection(Value: TPositionedLayer);
property Selection: TPositionedLayer read FSelection write SetSelection;
Procedure SelectGraficLayer(idu:string);
procedure AddTransparentPNGlayer;
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
var
imwidth: integer;
imheight: integer;
OffsX, OffsY: Integer;
const
penwidth = 3;
pencolor = clBlue; // Needs to be a VCL color!
procedure TForm5.AddLineToLayer;
begin
bm32.Canvas.Pen.Color := pencolor;
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
procedure TForm5.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
begin
imwidth := Form5.ImgView.Width;
imheight := Form5.ImgView.Height;
with ImgView.PaintStages[0]^ do
begin
if Stage = PST_CLEAR_BACKGND then Stage := PST_CUSTOM;
end;
bm32 := TBitmap32.Create;
bm32.DrawMode := dmTransparent;
bm32.SetSize(imwidth,imheight);
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.Pen.Color := pencolor;
with ImgView do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Scaled := True;
Bitmap.DrawMode := dmTransparent;
Bitmap.SetSize(imwidth, imheight);
Bitmap.Canvas.Pen.Width := 4;//penwidth;
Bitmap.Canvas.Pen.Color := clBlue;
Bitmap.Canvas.FrameRect(Rect(20, 20, imwidth-20, imheight-20));
Bitmap.Canvas.TextOut(15, 32, 'ImgView');
end;
AddTransparentPNGLayer;
BL := TBitmapLayer.Create(ImgView.Layers);
try
BL.Bitmap.DrawMode := dmTransparent;
BL.Bitmap.SetSize(imwidth,imheight);
BL.Bitmap.Canvas.Pen.Width := penwidth;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
BL.Scaled := False;
BL.OnMouseDown := LayerMouseDown;
BL.OnMouseUp := LayerMouseUp;
BL.OnMouseMove := LayerMouseMove;
BL.OnPaint := LayerOnPaint;
except
Edit3.Text:=IntToStr(BL.Index);
BL.Free;
raise;
end;
FDrawingLine := false;
SwapBuffers32;
end;
procedure TForm5.FormDestroy(Sender: TObject);
begin
bm32.Free;
BL.Free;
end;
procedure TForm5.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
const //0..1
Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
R: TRect;
I, J: Integer;
OddY: Integer;
TilesHorz, TilesVert: Integer;
TileX, TileY: Integer;
TileHeight, TileWidth: Integer;
begin
TileHeight := 13;
TileWidth := 13;
TilesHorz := Buffer.Width div TileWidth;
TilesVert := Buffer.Height div TileHeight;
TileY := 0;
for J := 0 to TilesVert do
begin
TileX := 0;
OddY := J and $1;
for I := 0 to TilesHorz do
begin
R.Left := TileX;
R.Top := TileY;
R.Right := TileX + TileWidth;
R.Bottom := TileY + TileHeight;
Buffer.FillRectS(R, Colors[I and $1 = OddY]);
Inc(TileX, TileWidth);
end;
Inc(TileY, TileHeight);
end;
end;
procedure TForm5.ImgViewResize(Sender: TObject);
begin
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X-OffsX, Y-OffsY);
FDrawingLine := true;
end;
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm5.SetSelection(Value: TPositionedLayer);
begin
if Value <> FSelection then
begin
FSelection := Value;
end;
end;
procedure TForm5.SwapBuffers32;
begin
TransparentBlt(
BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;
procedure TForm5.AddTransparentPNGlayer;
var
mypng:TPortableNetworkGraphic32;
B : TBitmapLayer;
P: TPoint;
W, H: Single;
begin
try
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromFile('C:\Location\Of\ATransparentPNGFile.png');
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
except
Free;
raise;
end;
Selection := B;
Edit3.Text:=IntToStr(B.Index);
finally
mypng.Free;
end;
end;
end.
What am I doing wrong? Please test the unit above to see what I mean. Remember to add a ImgView and anchor it to all margins, then at runtime, maximize the form and try to draw the lines...
EDIT
In the green image above, there is a rect, more like a square in the middle of it (not very visible) but you can see it if you look closely.
Since my problem might be misunderstood, please take a look at the following image
I need to be able to draw ONLY in the white rectangle (Bitmap) in the middle of the ImgView. I do not know how to explain better.
It is not a solution for me to make the rectangle/Bitmap fit exactly the ImgView, because that is not the point of my project.
Take a look at Paint.net and imagine that my project kind of does the same (except it's not that complex). But the principle is the same: you decide the size of your document/image when you start a new project, then you add different images as layers, you scale and rotate them, and now I want to allow the users to draw lines inside of a special layer (the drawing layer)
But everything happens inside the boundaries of that document size. Like for example in the above image, the size of the document there is A5 (100dpi) scaled at 83%.
So my problem is that I cannot allow the users to draw the lines outside the white rectangle (middle of the screen). So their lines can start in those boundaries and end there.
I know my test unit is not perfectly clean. I pasted some functions used in the main project and quickly removed some parts from them that are not relevant to this example. The AddTransparentPng procedure is there only to allow the testing of adding a transparent image to the ImgView so I can test if the drawing layer is not covering another possible latyer.
(The Scaled property belongs to the layer (B) it's under the 'with B' statement. I removed the With 'ImgView.Bitmap... Location' statement so it would not bother you anymore :) )
Anyway, please do not pay attention to the code that does not affect the drawing of lines. That code is what needs attention.
EDIT
If I set the layer's scaled to true (Scaled:=true) then it messes everything up, like in the image bellow:
I still have to use offsets but a little differently
Thank you
Error one
In LayerMouseMove() you subtract OffsX and OffsY from FStartPoint in BL.Bitmap.Canvas.MoveTo(). FStartPoint was already adjusted in LayerMouseDown(). I told you to "In the three Mouse procs adjust the X and Y arguments only to become X-OffsX and Y-OffsY." Note arguments only Here's LayerMouseMove() corrected:
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
// BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
Error two
I also told you to add if FDrawingLine then ... condition to LayerMouseUp() to avoid spurious line when the mouse down happens outside of the layer, but mouse up occurs inside. The corrected LayerMouseUp():
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
end;
Error three
The posted code does not perform as your first image shows. The image looks like you would have outcommented the line BL.Location := ... in ImgViewResize(). Possibly you did this because of Error one. Anyway, with ImgViewResize as follows and the other corrections above I get the result as shown in the picture that follows.
procedure TForm5.ImgViewResize(Sender: TObject);
begin
// centering the drawing area
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
Variables imwidth and imheight defines the size of the drawing area. If you change these you need to recalculate OffsX and OffsY and you need to resize the backbuffer bm32 as well.
The lines in the corners indicate the extent of the drawing area (defined by imwidth and imheight) in the middle of the window. It stays the same also when the window is maximized.
Ok, I solved it. Here is the final (relevant) code:
procedure TForm5.ImgViewResize(Sender: TObject);
begin
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
procedure TForm5.SwapBuffers32;
begin
TransparentBlt(
BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;
procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X-OffsX, Y-OffsY);
FDrawingLine := true;
end;
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm5.AddLineToLayer;
begin
bm32.Canvas.Pen.Color := pencolor;
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
With this code, everything works as expected. The drawing of lines can only happen within the boundaries
Thank you
I created a Custom scrollbox derives from TScrollbox that works the same except that it will scrolls when dragging in the client area aside from its scrollbars.
My problem now is i cannot Drag To Scroll when mouse is on a button or panel inside my CustomScrollbox.
the MouseDown, MouseUp, MouseMove override will not trigger because it hovers into different controls.
How can I keep tracking the MouseDown, MouseUp, MouseMove and prevent Button/Panels events from firing(inside my CustomScrollbox) when i start dragging?
here's the video of my smooth CustomScrollbox
So you want to adjust the mouse down behaviour of all childs, in such way that when a dragging operation is being initiated, the mouse events of the clicked child should be ignored. But when no drag is performed, then it would be required to fire the child's mouse events as usual.
Not a bad question actually. Since most of the default control interaction is tight to the release of the mouse button (e.g. OnClick is handled in WM_LBUTTONUP), this still should be possible in an intuitive manner.
I tried the code below, and it feels quite nice indeed. It involves:
handling WM_PARENTNOTIFY to catch when a child control is clicked on,
bypassing Child.OnMouseMove and Child.OnMouseUp,
transfer control to the scrollbox when the move exceeds Mouse.DragThreshold,
resetting focus to the previous focussed control before the drag,
canceling all changes made to the child's mouse events after the drag.
unit Unit2;
interface
uses
Windows, Messages, Classes, Controls, Forms, StdCtrls, ExtCtrls;
type
TScrollBox = class(Forms.TScrollBox)
private
FChild: TControl;
FDragging: Boolean;
FPrevActiveControl: TWinControl;
FPrevScrollPos: TPoint;
FPrevTick: Cardinal;
FOldChildOnMouseMove: TMouseMoveEvent;
FOldChildOnMouseUp: TMouseEvent;
FSpeedX: Single;
FSpeedY: Single;
FStartPos: TPoint;
FTracker: TTimer;
function ActiveControl: TWinControl;
procedure ChildMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ChildMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
function GetScrollPos: TPoint;
procedure SetScrollPos(const Value: TPoint);
procedure Track(Sender: TObject);
procedure WMParentNotify(var Message: TWMParentNotify);
message WM_PARENTNOTIFY;
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
public
constructor Create(AOwner: TComponent); override;
property ScrollPos: TPoint read GetScrollPos write SetScrollPos;
end;
TForm2 = class(TForm)
ScrollBox1: TScrollBox;
...
end;
implementation
{$R *.dfm}
{ TScrollBox }
type
TControlAccess = class(TControl);
function TScrollBox.ActiveControl: TWinControl;
var
Control: TWinControl;
begin
Result := Screen.ActiveControl;
Control := Result;
while (Control <> nil) do
begin
if Control = Self then
Exit;
Control := Control.Parent;
end;
Result := nil;
end;
procedure TScrollBox.ChildMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if (Abs(FChild.Left + X - FStartPos.X) > Mouse.DragThreshold) or
(Abs(FChild.Top + Y - FStartPos.Y) > Mouse.DragThreshold) then
begin
MouseCapture := True;
TControlAccess(FChild).OnMouseMove := FOldChildOnMouseMove;
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
MouseDown(mbLeft, Shift, FChild.Left + X, FChild.Top + Y);
FChild := nil;
if FPrevActiveControl <> nil then
FPrevActiveControl.SetFocus;
end
else
if Assigned(FOldChildOnMouseMove) then
FOldChildOnMouseMove(Sender, Shift, X, Y);
end;
procedure TScrollBox.ChildMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if FChild <> nil then
begin
if Assigned(FOldChildOnMouseUp) then
FOldChildOnMouseUp(Sender, Button, Shift, X, Y);
TControlAccess(FChild).OnMouseMove := FOldChildOnMouseMove;
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
FChild := nil;
end;
end;
constructor TScrollBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTracker := TTimer.Create(Self);
FTracker.Enabled := False;
FTracker.Interval := 15;
FTracker.OnTimer := Track;
end;
function TScrollBox.GetScrollPos: TPoint;
begin
Result := Point(HorzScrollBar.Position, VertScrollBar.Position);
end;
procedure TScrollBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
FDragging := True;
FPrevTick := GetTickCount;
FPrevScrollPos := ScrollPos;
FTracker.Enabled := True;
FStartPos := Point(ScrollPos.X + X, ScrollPos.Y + Y);
Screen.Cursor := crHandPoint;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TScrollBox.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if FDragging then
ScrollPos := Point(FStartPos.X - X, FStartPos.Y - Y);
inherited MouseMove(Shift, X, Y);
end;
procedure TScrollBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
FDragging := False;
Screen.Cursor := crDefault;
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TScrollBox.SetScrollPos(const Value: TPoint);
begin
HorzScrollBar.Position := Value.X;
VertScrollBar.Position := Value.Y;
end;
procedure TScrollBox.Track(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
FTracker.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;
procedure TScrollBox.WMParentNotify(var Message: TWMParentNotify);
begin
inherited;
if Message.Event = WM_LBUTTONDOWN then
begin
FChild := ControlAtPos(Point(Message.XPos, Message.YPos), False, True);
if FChild <> nil then
begin
FPrevActiveControl := ActiveControl;
FOldChildOnMouseMove := TControlAccess(FChild).OnMouseMove;
TControlAccess(FChild).OnMouseMove := ChildMouseMove;
FOldChildOnMouseUp := TControlAccess(FChild).OnMouseUp;
TControlAccess(FChild).OnMouseUp := ChildMouseUp;
end;
end;
end;
end.
Note: When no drag is initiated (mouse movement < Mouse.DragThreshold), all mouse and click events of the clicked child remain intact. Otherwise only Child.OnMouseDown will fire!
For testing purposes, this answer is incorporated in the code above.
With thanks to #TLama for suggesting to use WM_PARENTNOTIFY.
Anyone know how to drag the report in TppViewer? (Delphi 7) i try to use the dagdrop event and dragover event of ppviewer but failed, anyone can help?
procedure Tfrm1.ppviewer1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
inherited;
Accept := Source IS TppViewer;
end;
procedure Tfrm1.ppviewer1DragDrop(Sender, Source: TObject; X,
Y: Integer);
begin
inherited;
if Source is TppViewer then begin
TppViewer(Source).Left := X;
TppViewer(Source).Top := Y;
end;
end;
This answer assumes that you are trying to scroll in the report, by dragging.
TReportPreviewer is the Form
ReportViewer is the ppViewer
Dragging is a Boolean
SaveX, SaveY are Integer
procedure TReportPreviewer.ReportViewerMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Dragging := true;
SaveX := X;
SaveY := Y;
end;
procedure TReportPreviewer.ReportViewerMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if Dragging then
begin
if ReportViewer.ScrollBox.Visible then
ReportViewer.ScrollBox.HorzScrollBar.Position := ReportViewer.ScrollBox.HorzScrollBar.Position - (X - SaveX);
if ReportViewer.ScrollBox.Visible then
ReportViewer.ScrollBox.VertScrollBar.Position := ReportViewer.ScrollBox.VertScrollBar.Position - (Y - SaveY);
SaveX := X;
SaveY := Y;
end;
end;
procedure TReportPreviewer.ReportViewerMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Dragging := false;
end;
I tried using ScrollBy instead of moving the scrollbar position, but it seemed to reset for some reason.
Are you trying to drag a report file into the Viewer? if so biased on the following advice:
How to Drop Images from Windows Explorer to a TImage control
Delphi - Drag & Drop with ListView
WM_DROPFILES Message
You can achieve this by using the following code:
procedure TMainForm.FormCreate(Sender: TObject);
begin
//Tell Windows that the Report Viewer accepts files
ShellAPI.DragAcceptFiles(ppViewer1.Handle,True);
Application.OnMessage := ApplicationMessage;
end;
procedure TMainForm.ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
begin
if (Msg.hwnd = ppViewer1.Handle) and (Msg.message = WM_DROPFILES) then
begin
Handled := ReportFileDrop(Msg);
end;
end;
function TMainForm.ReportFileDrop(var Msg: TMsg):Boolean ;
var
numFiles : longInt;
buffer : array[0..MAX_PATH] of char;
l_file:String;
l_filemsg:TWMDROPFILES;
begin
Result := False;
//Convert the TMsg into a TWMDROPFILES record
l_filemsg.Msg := Msg.message;
l_filemsg.Drop := Msg.wParam;
l_filemsg.Unused := Msg.lParam;
l_filemsg.Result := 0;
numFiles := DragQueryFile(l_filemsg.Drop, $FFFFFFFF, nil, 0) ;
if numFiles > 1 then
begin
ShowMessage('You can drop only one file at a time!') ;
end
else
begin
try
DragQueryFile(l_filemsg.Drop, 0, #buffer, sizeof(buffer)) ;
l_file := buffer;
//Only try and load the report if the file has the correct extension
if (Length(l_file) > 0) and (ExtractFileExt(LowerCase(l_file)) = '.rtm') then
begin
//Load the Report
Result := True;
end;
except
//Handle errors
end;
end;
end;
I need to implement a pan as I click and drag the mouse, and zoom/unzoom towards/away from the mouse cursor that uses the mouse wheel. (In Delphi 2010, with the image anchored to left,right,top,bottom the form.)
I've just installed Graphics32 and seen how its built-in scroll bars and .Scale allow some of this. It's tantalizingly easy to at least get that far.
Questions:
Is Graphics32 a good tool for this kind of thing? Are there other (perhaps more simple?) tools that I might look into?
Does anyone have any pointers or sample code on how to implement the above?
Thanks.
Graphics32 provides a component named TImgView32 which can zoom by setting the Scale property. The appropriate way to do so is by using the OnMouseWheelUp and -Down events. Set TabStop to True for triggering these events and set Centered to False. But scaling in this manner does not comply with your wish to center the zooming operation at the mouse cursor. So repositioning and resizing around that point is a nicer solution. Further, as I understand, the image is always aligned in the top-left corner of the component, so panning must also be accomplished by repositioning the component.
uses
Windows, Classes, Controls, Forms, GR32_Image, GR32_Layers, Jpeg;
type
TForm1 = class(TForm)
ImgView: TImgView32;
procedure FormCreate(Sender: TObject);
procedure ImgViewMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
procedure ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FDragging: Boolean;
FFrom: TPoint;
end;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
ImgView.Bitmap.LoadFromFile('D:\Pictures\Mona_Lisa.jpg');
ImgView.TabStop := True;
ImgView.ScrollBars.Visibility := svHidden;
ImgView.ScaleMode := smResize;
end;
procedure TForm1.ImgViewMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
const
ZoomFactor: array[Boolean] of Single = (0.9, 1.1);
var
R: TRect;
begin
MousePos := ImgView.ScreenToClient(MousePos);
with ImgView, MousePos do
if PtInRect(ClientRect, MousePos) then
begin
R := BoundsRect;
R.Left := Left + X - Round(ZoomFactor[WheelDelta > 0] * X);
R.Top := Top + Y - Round(ZoomFactor[WheelDelta > 0] * Y);
R.Right := R.Left + Round(ZoomFactor[WheelDelta > 0] * Width);
R.Bottom := R.Top + Round(ZoomFactor[WheelDelta > 0] * Height);
BoundsRect := R;
Handled := True;
end;
end;
procedure TForm1.ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
FDragging := True;
ImgView.Enabled := False; { Temporarily, to get MouseMove to the parent }
FFrom := Point(X, Y);
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
ImgView.SetBounds(X - FFrom.X, Y - FFrom.Y, ImgView.Width, ImgView.Height);
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := False;
ImgView.Enabled := True;
ImgView.SetFocus;
end;
Edit: Alternative with TImage instead of TImgView32:
uses
Windows, Classes, Controls, Forms, Jpeg, ExtCtrls;
type
TForm1 = class(TForm)
Image: TImage;
procedure FormCreate(Sender: TObject);
procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ImageDblClick(Sender: TObject);
procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FDragging: Boolean;
FFrom: TPoint;
FOrgImgBounds: TRect;
end;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
DoubleBuffered := True;
Image.Picture.LoadFromFile('D:\Pictures\Mona_Lisa.jpg');
Image.Stretch := True;
Image.Height := Round(Image.Width * Image.Picture.Height / Image.Picture.Width);
FOrgImgBounds := Image.BoundsRect;
end;
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
const
ZoomFactor: array[Boolean] of Single = (0.9, 1.1);
var
R: TRect;
begin
MousePos := Image.ScreenToClient(MousePos);
with Image, MousePos do
if PtInRect(ClientRect, MousePos) and ((WheelDelta > 0) and
(Height < Self.ClientHeight) and (Width < Self.ClientWidth)) or
((WheelDelta < 0) and (Height > 20) and (Width > 20)) then
begin
R := BoundsRect;
R.Left := Left + X - Round(ZoomFactor[WheelDelta > 0] * X);
R.Top := Top + Y - Round(ZoomFactor[WheelDelta > 0] * Y);
R.Right := R.Left + Round(ZoomFactor[WheelDelta > 0] * Width);
R.Bottom := R.Top + Round(ZoomFactor[WheelDelta > 0] * Height);
BoundsRect := R;
Handled := True;
end;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
Image.SetBounds(X - FFrom.X, Y - FFrom.Y, Image.Width, Image.Height);
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Image.Enabled := True;
FDragging := False;
end;
procedure TForm1.ImageDblClick(Sender: TObject);
begin
Image.BoundsRect := FOrgImgBounds;
end;
procedure TForm1.ImageMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if not (ssDouble in Shift) then
begin
FDragging := True;
Image.Enabled := False;
FFrom := Point(X, Y);
MouseCapture := True;
end;
end;