I have a TScrollBox inside of a TFrame and when I use my mouse's wheel it simply does not goes up nor down the ScrollBox scrolling.
I have tried to use
TScrollBox(Sender).Perform(WM_VSCROLL,1,0);
on the FrameMouseWheelDown but it does not trigger.
Any Ideas?
My scroll box looks like this:
type
TMyScrollBox = class(TScrollBox)
protected
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
procedure WndProc(var Message: TMessage); override;
end;
function TMyScrollBox.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
if not Result then begin
if Shift*[ssShift..ssCtrl]=[] then begin
VertScrollBar.Position := VertScrollBar.Position - WheelDelta;
Result := True;
end;
end;
end;
procedure TMyScrollBox.WndProc(var Message: TMessage);
begin
if Message.Msg=WM_MOUSEHWHEEL then begin
(* For some reason using a message handler for WM_MOUSEHWHEEL doesn't work. The messages
don't always arrive. It seems to occur when both scroll bars are active. Strangely,
if we handle the message here, then the messages all get through. Go figure! *)
if TWMMouseWheel(Message).Keys=0 then begin
HorzScrollBar.Position := HorzScrollBar.Position + TWMMouseWheel(Message).WheelDelta;
Message.Result := 0;
end else begin
Message.Result := 1;
end;
end else begin
inherited;
end;
end;
You can use the OnMouseWheel event handler:
ScrollBar1.OnMouseWheel := ScrollBoxMouseWheel;
...
procedure TFrame1.ScrollBoxMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
Handled := True;
if WheelDelta < 0 then
TScrollBox(Sender).VertScrollBar.Position := TScrollBox(Sender).VertScrollBar.Position + TScrollBox(Sender).VertScrollBar.Increment
else
TScrollBox(Sender).VertScrollBar.Position := TScrollBox(Sender).VertScrollBar.Position - TScrollBox(Sender).VertScrollBar.Increment;
end;
Related
In a white full screen form I will have seven frames from the same source. I want to move them with the mouse and save that position when exit, for loading later in that same position. I can move a panel if I hold mouse down on it and move it, from a code I got in delphi.about.com
But if I click in a WinControl inside that panel, of course I do not get the OnMouseDown from the panel.
How can I move the panel (or the frame) moving any control inside it without coding on every component it has?
Here is a quick example that explains what I am referring to by an overlay:
TTransparentPanel = class(TPanel)
protected
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure CreateParams(var params: TCreateParams); override;
end;
procedure TTransparentPanel.CreateParams(var params: TCreateParams);
begin
inherited CreateParams(params);
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TTransparentPanel.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
SetBkMode (msg.DC, TRANSPARENT);
msg.result := 1;
end;
In the form you have something like this:
procedure TFormTest.FormCreate(Sender: TObject);
begin
FTransparentPanel := TTransparentPanel.Create(Self);
FTransparentPanel.Parent := self;
FTransparentPanel.Align := alClient;
FTransparentPanel.Visible := True;
FTransparentPanel.OnMouseDown := FormMouseDown;
FTransparentPanel.OnMouseUp := FormMouseUp;
FTransparentPanel.OnMouseMove := FormMouseMove;
end;
procedure TFormTest.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift:
TShiftState; X, Y: Integer);
var
I: Integer;
begin
// Check if there is a control under X, Y
FMoveControl := nil;
for I := 0 to ControlCount - 1 do
begin
if Controls[I] <> FTransparentPanel then
begin
if (Controls[I].Left <= X) and (Controls[I].Top <= Y) and
((Controls[I].Left + Controls[I].Width) >= X) and ((Controls[I].Top + Controls[I].Height) >= Y) then
begin
FMoveControl := Controls[I];
break;
end;
end;
end;
if Assigned(FMoveControl) then
begin
FStartLeft := FMoveControl.Left;
FStartTop := FMoveControl.Top;
FStartX := X;
FStartY := Y;
end;
end;
procedure TFormTest.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y:
Integer);
begin
// Move it
if Assigned(FMoveControl) then
begin
FMoveControl.Left := FStartLeft + (X - FStartX);
FMoveControl.Top := FStartTop + (Y - FStartY);
end;
end;
procedure TFormTest.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift:
TShiftState; X, Y: Integer);
begin
FMoveControl := nil;
end;
This flashes a little bit when you move the control but should give you an idea on how to proceed.
I'm creating a custom control which recognizes when the mouse is dragging, specifically using messages WM_LBUTTONDOWN, WM_LBUTTONUP, and WM_MOUSEMOVE. When the mouse goes down, I capture the position on the control, and then when the mouse moves, if the left mouse button is down, I do more handling (calculating between starting and ending points).
The problem is, I'm expecting the mouse to go out of the control, and even out of the form, but when the mouse leaves the control, it no longer captures mouse events. Is there a way I can handle specifically the WM_MOUSEMOVE and WM_LBUTTONUP messages without the mouse being over the control?
You can use SetCapture/ReleaseCapture Windows API to continue to get mouse events when the cursor moves outside the control.
Releasecapture will work for Wincontrols, an other way could be a Mousehook. That's just a demo ....
unit MouseHook;
// 2012 by Thomas Wassermann
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm3 = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
var
HookHandle: Cardinal;
Type
tagMSLLHOOKSTRUCT = record
POINT: TPoint;
mouseData: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: DWORD;
end;
TMSLLHOOKSTRUCT = tagMSLLHOOKSTRUCT;
PMSLLHOOKSTRUCT = ^TMSLLHOOKSTRUCT;
{$R *.dfm}
function LowLevelMouseProc(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; stdcall;
var
Delta:Smallint;
begin
if (nCode >= 0) then
begin
Form3.Caption := Format('X: %d Y: %d ', [PMSLLHOOKSTRUCT(lParam)^.Point.X, PMSLLHOOKSTRUCT(lParam)^.Point.Y]);
if wParam = WM_LButtonDOWN then Form3.Caption := Form3.Caption + ' LD';
if wParam = WM_LButtonUP then Form3.Caption := Form3.Caption + ' LU';
if wParam = WM_RButtonDOWN then Form3.Caption := Form3.Caption + ' RD';
if wParam = WM_RButtonUP then Form3.Caption := Form3.Caption + ' RU';
if wParam = WM_MOUSEMOVE then Form3.Caption := Form3.Caption + ' Move';
Delta := PMSLLHOOKSTRUCT(lParam)^.mouseData shr 16;
if wParam = WM_MOUSEWHEEL then
begin
Form3.Caption := Form3.Caption + ' Wheel ' ;
if Delta=120 then Form3.Caption := Form3.Caption + ' KLICK'
else if Delta > 0 then Form3.Caption := Form3.Caption +' UP'
else if Delta < 0 then Form3.Caption := Form3.Caption +' DOWN'
end;
if wParam = WM_MOUSEHWHEEL then
begin
Form3.Caption := Form3.Caption + ' HWheel';
if Delta=120 then Form3.Caption := Form3.Caption + ' KLICK'
else if Delta > 0 then Form3.Caption := Form3.Caption +' UP'
else if Delta < 0 then Form3.Caption := Form3.Caption +' DOWN'
end;
Form3.Caption := Form3.Caption +' >> '+ IntToStr(Delta)
end;
Result := CallNextHookEx(HookHandle, nCode, wParam, lParam);
end;
function InstallMouseHook: Boolean;
begin
Result := False;
if HookHandle = 0 then
begin
HookHandle := SetWindowsHookEx(WH_MOUSE_LL, #LowLevelMouseProc, hInstance, 0);
Result := HookHandle <> 0;
end;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
InstallMouseHook;
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
if HookHandle <> 0 then
UnhookWindowsHookEx(HookHandle);
end;
end.
I have accepted the answer above, but my final version of this implementation is quite different. I thought I'd share what I came up with, as implementing a unique mouse hook multiple times was a little tricky.
Now the demonstration bummi provided was fixed and built-in to the form's unit. I created a new unit and wrapped everything in there. The tricky part was that the function LowLevelMouseProc cannot be part of the class. Yet, within this function, it makes a call specific to the hook handle (Result := CallNextHookEx(HookHandle, nCode, wParam, lParam);). So what I did was created a bucket (TList) where I dump every instance of my mouse object. When this function is called, it iterates through this bucket and triggers the appropriate events of each instance. This model also includes built-in thread-safe protection (untested).
Here's the full unit:
JD.Mouse.pas
unit JD.Mouse;
interface
uses
Windows, Classes, SysUtils, Messages, Controls;
type
TJDMouseButtonPoints = Array[TMouseButton] of TPoint;
TJDMouseButtonStates = Array[TMouseButton] of Boolean;
TJDMouse = class(TComponent)
private
FOnButtonUp: TMouseEvent;
FOnMove: TMouseMoveEvent;
FOnButtonDown: TMouseEvent;
FButtonPoints: TJDMouseButtonPoints;
FButtonStates: TJDMouseButtonStates;
procedure SetCursorPos(const Value: TPoint);
function GetCursorPos: TPoint;
procedure DoButtonDown(const IsDown: Boolean; const Button: TMouseButton;
const Shift: TShiftState; const X, Y: Integer);
procedure DoMove(const Shift: TShiftState; const X, Y: Integer);
public
constructor Create(AOwner: TComponent);
destructor Destroy; override;
published
property CursorPos: TPoint read GetCursorPos write SetCursorPos;
property OnButtonDown: TMouseEvent read FOnButtonDown write FOnButtonDown;
property OnButtonUp: TMouseEvent read FOnButtonUp write FOnButtonUp;
property OnMove: TMouseMoveEvent read FOnMove write FOnMove;
end;
implementation
var
_Hook: Cardinal;
_Bucket: TList;
_Lock: TRTLCriticalSection;
procedure LockMouse;
begin
EnterCriticalSection(_Lock);
end;
procedure UnlockMouse;
begin
LeaveCriticalSection(_Lock);
end;
type
tagMSLLHOOKSTRUCT = record
POINT: TPoint;
mouseData: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: DWORD;
end;
TMSLLHOOKSTRUCT = tagMSLLHOOKSTRUCT;
PMSLLHOOKSTRUCT = ^TMSLLHOOKSTRUCT;
function LowLevelMouseProc(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; stdcall;
var
X: Integer;
Delta: Smallint;
M: TJDMouse;
P: TPoint;
Shift: TShiftState;
begin
if (nCode >= 0) then begin
LockMouse;
try
Delta := PMSLLHOOKSTRUCT(lParam)^.mouseData shr 16;
try
for X := 0 to _Bucket.Count - 1 do begin
try
M:= TJDMouse(_Bucket[X]);
P:= Controls.Mouse.CursorPos;
//Shift:= .....; //TODO
case wParam of
WM_LBUTTONDOWN: begin
M.DoButtonDown(True, mbLeft, Shift, P.X, P.Y);
end;
WM_LBUTTONUP: begin
M.DoButtonDown(False, mbLeft, Shift, P.X, P.Y);
end;
WM_RBUTTONDOWN: begin
M.DoButtonDown(True, mbRight, Shift, P.X, P.Y);
end;
WM_RBUTTONUP: begin
M.DoButtonDown(False, mbRight, Shift, P.X, P.Y);
end;
WM_MBUTTONDOWN: begin
M.DoButtonDown(True, mbMiddle, Shift, P.X, P.Y);
end;
WM_MBUTTONUP: begin
M.DoButtonDown(False, mbMiddle, Shift, P.X, P.Y);
end;
WM_MOUSEMOVE: begin
M.DoMove(Shift, P.X, P.Y);
end;
WM_MOUSEWHEEL: begin
//TODO
end;
WM_MOUSEHWHEEL: begin
//TODO
end;
end;
except
on e: exception do begin
//TODO
end;
end;
end;
except
on e: exception do begin
//TODO
end;
end;
finally
UnlockMouse;
end;
end;
Result:= CallNextHookEx(_Hook, nCode, wParam, lParam);
end;
{ TJDMouse }
constructor TJDMouse.Create(AOwner: TComponent);
begin
LockMouse;
try
_Bucket.Add(Self); //Add self to bucket, registering to get events
finally
UnlockMouse;
end;
end;
destructor TJDMouse.Destroy;
begin
LockMouse;
try
_Bucket.Delete(_Bucket.IndexOf(Self)); //Remove self from bucket
finally
UnlockMouse;
end;
inherited;
end;
procedure TJDMouse.DoButtonDown(const IsDown: Boolean;
const Button: TMouseButton; const Shift: TShiftState; const X, Y: Integer);
begin
//Do not use lock, this is called from the lock already
if IsDown then begin
if assigned(FOnButtonDown) then
FOnButtonDown(Self, Button, Shift, X, Y);
end else begin
if assigned(FOnButtonUp) then
FOnButtonUp(Self, Button, Shift, X, Y);
end;
end;
procedure TJDMouse.DoMove(const Shift: TShiftState; const X, Y: Integer);
begin
//Do not use lock, this is called from the lock already
if assigned(FOnMove) then
FOnMove(Self, Shift, X, Y);
end;
function TJDMouse.GetCursorPos: TPoint;
begin
LockMouse;
try
Result:= Controls.Mouse.CursorPos;
finally
UnlockMouse;
end;
end;
procedure TJDMouse.SetCursorPos(const Value: TPoint);
begin
LockMouse;
try
Controls.Mouse.CursorPos:= Value;
finally
UnlockMouse;
end;
end;
initialization
InitializeCriticalSection(_Lock);
_Bucket:= TList.Create;
_Hook:= SetWindowsHookEx(WH_MOUSE_LL, #LowLevelMouseProc, hInstance, 0);
finalization
UnhookWindowsHookEx(_Hook);
_Bucket.Free;
DeleteCriticalSection(_Lock);
end.
And here's how it's implemented:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FMouse: TJDMouse;
procedure MouseButtonDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseButtonUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseMoved(Sender: TObject; Shift: TShiftState; X, Y: Integer);
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
FMouse:= TJDMouse.Create(nil);
FMouse.OnButtonDown:= MouseButtonDown;
FMouse.OnButtonUp:= MouseButtonUp;
FMouse.OnMove:= MouseMoved;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FMouse.Free;
end;
procedure TForm1.MouseButtonDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
end;
procedure TForm1.MouseButtonUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
end;
procedure TForm1.MouseMoved(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
end;
end.
You can use the TControlStyle.csCaptureMouse flag if you're using VCL controls. I'm not sure if there is a FMX counterpart. Relevant docs here.
I use csCaptureMouse in many of my custom controls and it works well.
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.
I have a TScrollBar having a code in the OnScroll event.
I want to scroll it using the mouse wheel, but turning the mouse wheel does not scroll the scroll bar and does not trigger the OnScroll event.
Any idea?
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
I: Integer;
begin
Handled := PtInRect(ScrollBox1.ClientRect, ScrollBox1.ScreenToClient(MousePos));
if Handled then
for I := 1 to Mouse.WheelScrollLines do
try
if WheelDelta > 0 then
ScrollBox1.Perform(WM_VSCROLL, SB_LINEUP, 0)
else
ScrollBox1.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
finally
ScrollBox1.Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
end;
end;
The default TScrollBar component indeed seems not to have the OnMouseWheel* events present. But you can simply assign them, as follows:
type
TForm1 = class(TForm)
ScrollBar1: TScrollBar;
procedure FormCreate(Sender: TObject);
procedure ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode;
var ScrollPos: Integer);
private
procedure ScrollBarMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
ScrollBar1.OnMouseWheel := ScrollBarMouseWheel;
end;
procedure TForm1.ScrollBarMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
NewScrollPos: Integer;
begin
NewScrollPos := ScrollBar1.Position - WheelDelta;
//Trigger the OnScroll event:
ScrollBar1.Scroll(scPosition, NewScrollPos);
//Scroll the bar into the new position:
ScrollBar1.Position := NewScrollPos;
Handled := True;
end;
You are free to implement this some more creative:
if WheelDelta > 0 then
NewScrollPos := ScrollBar1.Position - ScrollBar1.PageSize
else
NewScrollPos := ScrollBar1.Position + ScrollBar1.PageSize;
And you could interpose the TScrollBar class to prevent to assign the event at runtime:
type
TScrollBar = class(StdCtrls.TScrollBar)
protected
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
end;
function TScrollBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
var
NewScrollPos: Integer;
begin
NewScrollPos := Position - WheelDelta;
Scroll(scPosition, NewScrollPos);
Position := NewScrollPos;
Result := True;
end;
it's too easy just increase the position Value .
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
self.VertScrollBar.Position := self.VertScrollBar.Position + WheelDelta;
end;
I don't know if this will help much, but here's how to do it with a TMemo. The scrollbar would have to be a similar process, unless there is some other better way that Delphi versions later than mine use.
procedure TForm1.Memo1WindowProc(var msg: TMessage);
var
ticks: ShortInt;
ScrollMsg: TWMVScroll;
begin
if msg.Msg = WM_MOUSEWHEEL then
begin
ScrollMsg.Msg := WM_VSCROLL;
ticks := HiWord(msg.wparam);
if ticks > 0 then
ScrollMsg.ScrollCode := sb_LineUp
else
ScrollMsg.ScrollCode := sb_LineDown;
ScrollMsg.Pos:=0;
Memo1.Dispatch(ScrollMsg) ;
end
else
OldMemo1(msg);
end;
procedure TForm1.FormCreate(Sender: TObject);
// save old window proc, assign mine.
begin
OldMemo1 := Memo1.WindowProc;
Memo1.WindowProc := Memo1WindowProc;
end;
HTH some.
procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
ScrollBox1.VertScrollBar.Position := ScrollBox1.VertScrollBar.Position + 20;
end;
procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
ScrollBox1.VertScrollBar.Position := ScrollBox1.VertScrollBar.Position - 20;
end;
Old post, but I found solution. Simply do
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
inherited;
ScrollBox1.ScrollBy(WheelDelta, 0);
end;
Works for me.
Again this is an old post, and it got me most of the way to what i wanted but a little further tweak to the answer by Stefan, restricting scrolling to when the mouse is over the scrollbar. This detects that the mouse is over the scrollbar (non-client area) of the scroll box before accepting the mousewheel input./ I need this because my scollbox contained comboboxes which users wanted to be able to scrool with the wheel, as well as scrolling the scrollbox (or whatever control is using a scrollbar):
Handled := PtInRect(scrollbox.BoundsRect, scrollbox.ScreenToClient(MousePos))
and not PtInRect(scrollbox.ClientRect, scrollbox.ScreenToClient(MousePos));
if Handled then
for I := 1 to Mouse.WheelScrollLines do
try
if WheelDelta > 0 then
scrollbox.Perform(WM_VSCROLL, SB_LINEUP, 0)
else
scrollbox.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
finally
scrollbox.Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
end;
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;