I have to write program in Delphi using VCL forms. Three figures which are square, hexagon and octagonal must move to up border, then to bottom border and so on. The problem is that my program freezes, when I'm trying to put values in condition operators to stop moving, if coordinate Y = 0. Though it works(strangely) if I put value = 180, for example.
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TMainForm = class(TForm)
Image: TImage;
BeginButton: TButton;
EndButton: TButton;
Timer1: TTimer;
Edit1: TEdit;
procedure FormActivate(Sender: TObject);
procedure BeginButtonClick(Sender: TObject);
procedure EndButtonClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
uses Figure;
{$R *.dfm}
Var
t:single=0.0;
L:TSquare;
S:THexagon;
C:TOctagon;
Moving:Boolean=true;
procedure TMainForm.FormActivate(Sender: TObject);
begin
Image.Canvas.Brush.Color:=clWhite;
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
begin
L.Move(t);
S.Move(-0.2*t);
C.Move(0.5*t);
t:=t+0.5;
end;
procedure TMainForm.BeginButtonClick(Sender: TObject);
begin
L:=TSquare.Create(60,35,Image);
S:=THexagon.Create(180,100,Image);
C:=TOctagon.Create(300,100,Image);
Timer1.Enabled:=true;
end;
procedure TMainForm.EndButtonClick(Sender: TObject);
begin
Close;
end;
initialization
finalization
L.Free;
S.Free;
C.Free;
end.
And second Unit:
Unit Figure;
Interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
Type
TFigure=Class
private x,y, b,
dx:integer;
Image:TImage;
procedure Draw;virtual;abstract;
procedure Rel(t:real);virtual;
public
constructor Create(ax,ay:integer;aImage:TImage);
procedure Move(t:single);
end;
THexagon=Class(TFigure)
private procedure Draw;override;
end;
TSquare=Class(TFigure)
private procedure Draw;override;
end;
TOctagon=Class(TFigure)
private procedure Draw;override;
end;
Implementation
Constructor TFigure.Create;
Begin
inherited Create;
x:=ax; y:=ay; Image:=aImage;
End;
Procedure TFigure.Rel;
Begin
dx:=5*round(t);
End;
Procedure TFigure.Move;
Begin
Image.Canvas.Pen.Color:=clWhite;
Draw;
Image.Canvas.Pen.Color:=clBlack;
Rel(t);
Draw;
End;
Procedure TSquare.Draw;
Begin
b:=70;
Image.Canvas.MoveTo(x+round(0.5*b),y-round(0.5*b));
Image.Canvas.LineTo(x-round(0.5*b),y-round(0.5*b));
Image.Canvas.LineTo(x-round(0.5*b),y+round(0.5*b));
Image.Canvas.LineTo(x+round(0.5*b),y+round(0.5*b));
Image.Canvas.LineTo(x+round(0.5*b),y-round(0.5*b));
End;
Procedure THexagon.Draw;
Begin
b:=70;
repeat
begin
Image.Canvas.MoveTo(x+round(0.5*b),y+dx);
Image.Canvas.LineTo(x+round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.5*b),y+dx);
Image.Canvas.LineTo(x-round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.5*b),y+dx);
end;
until ((y+round(0.5*b)+dx)<180);
End;
Procedure TOctagon.Draw;
var
I: Integer;
p: array[1..9] of tpoint;
u:extended;
Begin
x:=300;
y:=100;
u:=0;
for I := 1 to 8 do
begin
p[i].X:=x+round(40*cos(u));
p[i].Y:=y-round(40*sin(u));
u:=u+pi/4;
end;
repeat
begin
Image.Canvas.MoveTo(p[8].x,p[8].y-dx);
for I := 1 to 8 do
Image.Canvas.LineTo(p[i].X,p[i].y-dx);
end;
until (p[3].y>50);
End;
end.
Delphi comes with an integrated debugger. You should use it. Here's how to start investigating a case where a program seems to hang.
Start your program under control of the debugger with the "play" button.
Reproduce the situation you're trying to investigate.
When the program hangs, switch to the debugger and press the "pause" button. The debugger will interrupt the execution of your program so you can investigate the current state.
Look at the call stack. (If the call-stack window isn't already visible, you can show it by using the "debug windows" menu option in the IDE.)
The call stack will show the list of functions your program has called. At the top of the stack will be the function your program was running at the moment you paused. The function below it will be the function that called the current function, and so on until you reach the bottom of the stack, which represents the main function of your program.
The function you stop in probably won't be one you wrote. Instead, it's usually a function provided by the OS or by the Delphi run-time library. You don't want to debug those. Generally, you can assume they already work properly. You're looking for a bug in your code instead.
Use the "run until return" command to let the topmost function continue running. Repeat that until you reach one of your functions on the call stack. That's probably the culprit.
Now that you've identified the problematic function, it's time to investigate it further.
Use the "step over" debugger command to run each line of your function one by one. (There's also a "step into" command, but that will step into functions that aren't yours, and you're not interested in those now.)
Observe the current values of variables in your code. You can hover the mouse over a variable to let the debugger display its value in a tool tip, or you can use the "watches" debug window to display multiple variables at once. They'll be updated after each step in your program.
Pay attention to the variables' values. You should already have some expectation of how their values should progress over the course of your program. You probably thought about that progression while you were writing the code. Think back to that time and compare the results you observe in the debugger with your previous expectations. Do they match? If so, then keep stepping through the code. If they don't match, though, then you've found a bug. Fix it.
Another source of unexpected behavior is to reach a point in your program that you didn't expect to reach. Maybe the program called a function it shouldn't have, or maybe you've executed a loop more times you wanted to. If you can work out the reason, then fix the bug. Otherwise, you might need to back up a little ways.
Identify a point in your program earlier than where you have observed the unexpected behavior. Look for the blue dots in the left margin of the code editor. Those dots represent places where you can set a breakpoint. Click one of the dots, and you should notice the line be highlighted (probably in red).
Terminate your program, and run it again.
This time, you should see the debugger stop before the program appears to hang because execution will have reached the breakpoint first. The debugger interrupts your program there.
Step through the lines of your code as you did before, and watch for the condition that causes your program to veer from the expected path of execution. When you've identified the bug, fix it.
It freezes because your repeat-until loop will never end.
repeat
begin
Image.Canvas.MoveTo(x+round(0.5*b),y+dx);
Image.Canvas.LineTo(x+round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.5*b),y+dx);
Image.Canvas.LineTo(x-round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.5*b),y+dx);
end;
until ((y+round(0.5*b)+dx)<180);
Its condition is based on y, b and dx values but they never change in your loop.
To confirm where it hangs, use the Pause command in Delphi, then press F7/F8 to run it step by step.
I have a form containing a TFrame. The TFrame contains a ComboBox that is dynamically populated. Each ComboBox entry has an associated object. By the time the overridden destructor for the TFrame is called, the Items in the ComboBox have already been cleared without freeing their associated objects. This happens whether I drop the ComboBox on the form in designer view, or dynamically create it in code with either nil or the TFrame as its owner. I currently use the OnDestroy event of the containing TForm to call a clean-up procedure of the contained TFrame.
Is there a better way that would not need an explicit procedure call by the TFrame's container? Where ideally should the objects added dynamically to the ComboBox be freed?
You say that when the destructor for the TFrame is called, the Items of the ComboBox have already been cleared. That's not the case, ComboBox items are never cleared. When Items is destroyed by the ComboBox, they've got a count of only 0.
When you exit your application and the VCL destroys the form containing the frame and the ComboBox, the native ComboBox control is also destroyed by the OS since it is placed in a window being destroyed. When you later access the items to be able to free your objects in the frame destructor, the VCL have to recreate a native ComboBox control, having an item count of 0.
The solution I'd propose is easy. Don't leave freeing your frame to the framework, instead, destroy your frame in the OnDestroy event of your form. That would be before the underlying window of the form is destroyed, hence you'll be able to access your objects.
form unit
procedure TMyForm.FormDestroy(Sender: TObject);
begin
MyFrame.Free;
end;
frame unit
destructor TMyFrame.Destroy;
var
i: Integer;
begin
for i := 0 to ComboBox1.Items.Count - 1 do
ComboBox1.Items.Objects[i].Free;
inherited;
end;
You could utilize the TFrame's WM_DESTROY handler like this:
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls;
type
TFrame1 = class(TFrame)
ComboBox1: TComboBox;
private
procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;
procedure FreeComboBoxItems;
public
constructor Create(AOwner: TComponent); override;
end;
implementation
{$R *.dfm}
constructor TFrame1.Create(AOwner: TComponent);
begin
inherited;
// Add some object items to the ComboBox
ComboBox1.AddItem('a', TButton.Create(nil));
ComboBox1.AddItem('b', TMemoryStream.Create);
ComboBox1.AddItem('c', TList.Create);
end;
procedure TFrame1.WMDestroy(var Msg: TWMDestroy);
begin
// Make sure the TFrame is actually destroying - not recreated
if (csDestroying in ComponentState) then
FreeComboBoxItems;
inherited;
end;
procedure TFrame1.FreeComboBoxItems;
var
I: Integer;
begin
OutputDebugString('TFrame1.FreeComboBoxItems');
with Self.ComboBox1 do
for I := 0 to Items.Count - 1 do
begin
OutputDebugString(PChar(Items.Objects[I].ClassName + '.Free'));
Items.Objects[I].Free;
end;
end;
end.
Another option is to create a Base ancestor TAppBaseForm class and a TAppBaseFrame for the entire application, and derive all your Forms as TAppBaseForm and all Frames as TAppBaseFrame.
This way the TAppBaseForm could notify all it's child TAppBaseFrame that the owner Form is destroyed on TAppBaseForm.FormDestroy event handler. At that point the ComboBox items are still valid (as described by Sertac Akyuz's answer).
Your question isn't really usefull, because - generally speaking - it is discouraged to store data (or objects in your case) in a GUI control. See also David's comment on how to change your design.
What makes the question kind of interresting to answer though is the difference between the combo box being a child of a form directly and being a child of another child of the form (your frame in this case). Apparently, the combo box items are destroyed before the destructor of that frame is called. Obvious alternatives to explore are then: overriding Frame.BeforeDestruction, overriding Frame.DestroyWindowHandle, overriding Frame.DestroyWnd, or catching WM_DESTROY in an overridden Frame.WndProc, but none of them is called before the items are already gone.
The next thing to try is to repeat this for the combo box. It turns out that when WM_DESTROY arrives at the combo box that the items are still there. However, beware of catching that message ónly when the control really is being destroyed, because the VCL might recreate a combo box frequently. Implement it using an interposing class for TComboBox, as follows:
unit Unit2;
interface
uses
Windows, Messages, Classes, Controls, Forms, StdCtrls;
type
TComboBox = class(StdCtrls.TComboBox)
protected
procedure WndProc(var Message: TMessage); override;
end;
TFrame1 = class(TFrame)
ComboBox1: TComboBox;
end;
implementation
{$R *.dfm}
{ TComboBox }
procedure TComboBox.WndProc(var Message: TMessage);
var
I: Integer;
begin
if (Message.Msg = WM_DESTROY) and (csDestroying in ComponentState) then
for I := 0 to Items.Count - 1 do
Items.Objects[I].Free;
inherited WndProc(Message);
end;
end.
Now, to answer your question: "Is this a better way?"
Yes it is, because it offers assurance of the object's destruction at the frame's level. In other words: you don't have to remember to deal with this for every instance seperately.
And no it is not, because this solution requires that the objects in the combo box are allowed to be freed in whatever circumstance which restricts usage to an unnecessary extra boundary.
So, is this answer usefull? Well, if it prevents you from using your current approach, then it is.
Besides, I also found another alternative by setting the frame's Parent property to nil in the containing form OnDestroy handler:
procedure TForm2.FormDestroy(Sender: TObject);
begin
Frame1.Parent := nil;
end;
In this case, you can safely destroy the objects stored in the combo box within the frame's destructor. But this solution is even worse than your current one, because it is not descriptive. Then Frame1.FreeComboObjects is much better.
freeing Combobox.Items.Objects in destructor is too late.
so, according to previous answers it is better and safe to do that this way:
procedure TMyFrame.ClearCBObjects;
var
i: Integer;
begin
for i := 0 to ComboBox1.Items.Count - 1 do
ComboBox1.Items.Objects[i].Free;
end;
destructor TMyFrame.Destroy;
begin
//Free none Component objects
inherited;
end;
destructor TMyForm.Destroy;
begin
MyFrame.ClearCBObjects;
inherited;
end;
I would like to know where is the formshow in delphi 2010 as when I can only see a formcreate in my project.
The reason I am asking is because I need to add Randomize in the FormShow event handler, as shown below:
procedure TfrmWinnaSpree.FormShow(Sender: TObject);
begin
Randomize;
end;
You create the event handler the same way you create almost every event handler in Delphi, by double-clicking the method in the Events tab of the Object Inspector.
Click on the form itself (not any control on the form), then switch to the Object Inspector. Click on the Events tab, and then scroll down to the OnShow event. Double-click in the right half next to the event name, and the IDE will create a new, empty event handler and put the cursor in the right place to start writing code.
procedure TForm3.FormShow(Sender: TObject);
begin
|
end;
However, FormShow is the wrong place to call Randomize, because FormShow executes every time your form is shown, and that can happen more than once. Here's an example (it assumes two forms, Form1 and Form2, autocreated as usual in the .dpr file with the default variable names, which of course is a bad idea - this is to demonstrate a problem with your question's purpose):
procedure TForm2.FormShow(Sender: TObject);
begin
ShowMessage('In FormShow');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Visible := not Form2.Visible;
end;
Run the program and click TForm1.Button1 multiple times; you'll see the In FormShow message every other time you do so.
The proper places for a call to Randomize are:
in your main form's FormCreate
in an initialization section of your main form's unit
unit uMainForm;
interface
...
implementation
...
initialization
Randomize;
end.
in your project source (.dpr) file
program MyGreatApp;
uses
Math,
Vcl.Forms,
uMainForm in 'uMainForm.pas' {Form1};
{$R *.RES}
begin
Randomize;
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.Title := 'My Super App';
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Alternatively you can also override the protected method TForm.DoShow:
type
TForm = class(Forms.TForm)
protected
procedure DoShow; override;
end;
implementation
procedure TForm.DoShow;
begin.
// custom show code
inherited;
// custom show code
end;
The advantage over the event-based approach is that you can put your custom code before or after the inherited call.
I'm stuck on a problem in Delphi 7 about event propagation (due to my ignorance).
I am asked to dynamically attach an OnMouseUp event handler on some controls on a form (and I'm fine with that thing), but if the OnMouseUp is present, the OnClick event on that control must not be processed.
Background
If you are asking the reason behind this, well, I'm in charge to modify an old production monitoring application (sigh) that from now on must accommodate a conditional behaviour for some controls, in direct response to a former click on a special function button.
Some of those controls have an OnClick event handler already; the first solution the team came up with was to punctually intervene on each OnClick handler and manage out the contextual actions in relation to the special function button status.
I suggested to take advantage of the Object-Oriented design already in place for the application forms: they all inherit from the same custom ancestor object, so I planned to insert an initialization method there to dynamically attach OnMouseUp events to the controls that are declared to support it in subclasses.
The need
I'm not hereby asking a validation or questioning on the (possible lack of) design goodness about all this (by the way, after a lot of thinking and reasoning it seemed to be the path we can walk with less pain); my problem is that for such design to take place I'd have to let dynamically-attached OnMouseUp event handlers stop event propagation to the pre-existent OnClick events on those controls.
Is it possible with Delphi 7?
Please note, the following does not explicitly answer the question here. It's more a proposal to the concept re-design (redirect OnClick events instead of adding extra OnMouseUp). It's about how to redirect OnClick event handler (if assigned some) of all components (might be filtered, if needed) to another (common) OnClick event handler. It includes also a method for restoring them to the original state.
In the following example I'll try to show you how to replace and then optionally restore the OnClick event handlers (if the component has written some) by the specific one. This is done to all components having the OnClick event published, so you don't need to know in advance if the component class has OnClick event available or not (but it can very simply be modified to use only a specific class).
The code consists from the following:
OnSpecialClick - it is the event handler to what all OnClick events will be binded when you call the ReplaceOnClickEvents procedure, notice that it must be published to be visible for RTTI !!!
Button1Click - represents here the old event handler which should be replaced, it is binded to the Button1.OnClick event at design time
ReplaceOnClickEvents - method, which iterates through all components on the form and checks if the currently iterated one has the OnClick event handler assigned; if so, it stores it into a backup collection and replace this event handler by the OnSpecialClick
RestoreOnClickEvents - method, which restores the original OnClick event handlers; it iterates through the backup collection and assign the event methods to its stored component instances
CheckBox1Click - this check box click event is meant to be the switch between the common and a special mode (CheckBox1 checked state means to be the special mode), only this OnClick event is not replaced by the ReplaceOnClickEvents call (because you wouldn't be able to restore the mode back to normal)
And here it is:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, TypInfo, StdCtrls, Contnrs;
type
TEventBackup = class
Component: TComponent;
OnClickMethod: TMethod;
end;
type
TForm1 = class(TForm)
Button1: TButton;
CheckBox1: TCheckBox;
procedure Button1Click(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
private
procedure ReplaceOnClickEvents;
procedure RestoreOnClickEvents;
published
procedure OnSpecialClick(Sender: TObject);
end;
var
Form1: TForm1;
EventBackupList: TObjectList;
implementation
{$R *.dfm}
procedure TForm1.OnSpecialClick(Sender: TObject);
begin
ShowMessage('Hi, I''m an OnSpecialClick event message!');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Hi, I''m just that boring original OnClick event message!');
end;
procedure TForm1.ReplaceOnClickEvents;
var
I: Integer;
Component: TComponent;
EventMethod: TMethod;
EventBackup: TEventBackup;
begin
for I := 0 to ComponentCount - 1 do
begin
Component := Components[I];
if Component = CheckBox1 then
Continue;
if IsPublishedProp(Component, 'OnClick') then
begin
EventMethod := GetMethodProp(Component, 'OnClick');
if Assigned(EventMethod.Code) and Assigned(EventMethod.Data) then
begin
EventBackup := TEventBackup.Create;
EventBackup.Component := Component;
EventBackup.OnClickMethod := EventMethod;
EventBackupList.Add(EventBackup);
EventMethod.Code := MethodAddress('OnSpecialClick');
EventMethod.Data := Pointer(Self);
SetMethodProp(Component, 'OnClick', EventMethod);
end;
end;
end;
end;
procedure TForm1.RestoreOnClickEvents;
var
I: Integer;
EventBackup: TEventBackup;
begin
for I := 0 to EventBackupList.Count - 1 do
begin
EventBackup := TEventBackup(EventBackupList[I]);
SetMethodProp(EventBackup.Component, 'OnClick', EventBackup.OnClickMethod);
end;
EventBackupList.Clear;
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
if CheckBox1.Checked then
ReplaceOnClickEvents
else
RestoreOnClickEvents;
end;
initialization
EventBackupList := TObjectList.Create;
EventBackupList.OwnsObjects := True;
finalization
EventBackupList.Free;
end.
As both TLama and TOndrej have said, there are a few ways to accomplish what you're attempting:
To do if Assigned(Control.OnMouseUp) then Exit; on your OnClick event handler
To "unassign" the OnClick event when assigning OnMouseUp (and vice-versa)
Both approaches will accomplish what you've detailed, though "unassigning" the OnClick event will be best for performance (to an infintismally small extent) since you won't be performing the if statement repeatedly.
I use a number of scrolling controls: TTreeViews, TListViews, DevExpress cxGrids and cxTreeLists, etc. When the mouse wheel is spun, the control with focus receives the input no matter what control the mouse cursor is over.
How do you direct the mouse wheel input to whatever control the mouse cursor is over? The Delphi IDE works very nicely in this regard.
Scrolling origins
An action with the mouse wheel results in a WM_MOUSEWHEEL message being sent:
Sent to the focus window when the mouse wheel is rotated. The DefWindowProc function propagates the message to the window's parent. There should be no internal forwarding of the message, since DefWindowProc propagates it up the parent chain until it finds a window that processes it.
A mouse wheel's odyssey 1)
The user scrolls the mouse wheel.
The system places a WM_MOUSEWHEEL message into the foreground window’s thread’s message queue.
The thread’s message loop fetches the message from the queue (Application.ProcessMessage). This message is of type TMsg which has a hwnd member designating the window handle the message is ment for.
The Application.OnMessage event is fired.
Setting the Handled parameter True stops further processing of the message (except for the next to steps).
The Application.IsPreProcessMessage method is called.
If no control has captured the mouse, the focused control's PreProcessMessage method is called, which does nothing by default. No control in the VCL has overriden this method.
The Application.IsHintMsg method is called.
The active hint window handles the message in an overriden IsHintMsg method. Preventing the message from further processing is not possible.
DispatchMessage is called.
The TWinControl.WndProc method of the focused window receives the message. This message is of type TMessage which lacks the window (because that is the instance this method is called upon).
The TWinControl.IsControlMouseMsg method is called to check whether the mouse message should be directed to one of its non-windowed child controls.
If there is a child control that has captured the mouse or is at the current mouse position2), then the message is sent to the child control's WndProc method, see step 10. (2) This will never happen, because WM_MOUSEWHEEL contains its mouse position in screen coordinates and IsControlMouseMsg assumes a mouse position in client coordinates (XE2).)
The inherited TControl.WndProc method receives the message.
When the system does not natively supports mouse wheel (< Win98 or < WinNT4.0), the message is converted to a CM_MOUSEWHEEL message and is send to TControl.MouseWheelHandler, see step 13.
Otherwise the message is dispatched to the appropriate message handler.
The TControl.WMMouseWheel method receives the message.
The WM_MOUSEWHEEL window message (meaningful to the system and often to the VCL too) is converted to a CM_MOUSEWHEEL control message (meaningful only to the VCL) which provides for the convenient VCL's ShiftState information instead of the system's keys data.
The control's MouseWheelHandler method is called.
If the control is a TCustomForm, then the TCustomForm.MouseWheelHandler method is called.
If there is a focused control on it, then CM_MOUSEWHEEL is sent to the focused control, see step 14.
Otherwise the inherited method is called, see step 13.2.
Otherwise the TControl.MouseWheelHandler method is called.
If there is a control that has captured the mouse and has no parent3), then the message is sent to that control, see step 8 or 10, depending on the type of the control. (3) This will never happen, because Capture is gotten with GetCaptureControl, which checks for Parent <> nil (XE2).)
If the control is on a form, then the control's form's MouseWheelHandler is called, see step 13.1.
Otherwise, or if the control ís the form, then CM_MOUSEWHEEL is sent to the control, see step 14.
The TControl.CMMouseWheel method receives the message.
The TControl.DoMouseWheel method is called.
The OnMouseWheel event is fired.
If not handled, then TControl.DoMouseWheelDown or TControl.DoMouseWheelUp is called, depending on the scroll direction.
The OnMouseWheelDown or the OnMouseWheelUp event is fired.
If not handled, then CM_MOUSEWHEEL is sent to the parent control, see step 14. (I believe this is against the advice given by MSDN in the quote above, but that undoubtedly is a thoughtful decision made by the developers. Possibly because that would start this very chain al over.)
Remarks, observations and considerations
At almost every step in this chain of processing the message can be ignored by doing nothing, altered by changing the message parameters, handled by acting on it, and canceled by setting Handled := True or setting Message.Result to non-zero.
Only when some control has focus, this message is received by the application. But even when Screen.ActiveCustomForm.ActiveControl is forcefully set to nil, the VCL ensures a focused control with TCustomForm.SetWindowFocus, which defaults to the previously active form. (With Windows.SetFocus(0), indeed the message is never sent.)
Due to the bug in IsControlMouseMsg 2), a TControl can only receive the WM_MOUSEWHEEL message if it has captured the mouse. This can manually be achieved by setting Control.MouseCapture := True, but you have to take special care of releasing that capture expeditiously, otherwise it will have unwanted side effects like the need for an unnecessary extra click to get something done. Besides, mouse capture typically only takes place between a mouse down and a mouse up event, but this restriction does not necessarily have to be applied. But even when the message reaches the control, it is sent to its MouseWheelHandler method which just sends it back to either the form or the active control. Thus non-windowed VCL controls can never act on the message by default. I believe this is another bug, otherwise why would all wheel handling have been implemented in TControl? Component writers may have implemented their own MouseWheelHandler method for this very purpose, and whatever solution comes to this question, there has to be taken care of not breaking this kind of existing customization.
Native controls which are capable of scrolling with the wheel, like TMemo, TListBox, TDateTimePicker, TComboBox, TTreeView, TListView, etc. are scrolled by the system itself. Sending CM_MOUSEWHEEL to such a control has no effect by default. These subclassed controls scroll as a result of the WM_MOUSEWHEEL message sent to the with the subclass associated API window procedure with CallWindowProc, which the VCL takes care of in TWinControl.DefaultHandler. Oddly enough, this routine does not check Message.Result before calling CallWindowProc, and once the message is sent, scrolling cannot be prevented. The message comes back with its Result set depending on whether the control normally is capable of scrolling or on the type of control. (E.g. a TMemo returns <> 0, and TEdit returns 0.) Whether it actually scrolled has no influence on the message result.
VCL controls rely on the default handling as implemented in TControl and TWinControl, as layed out above. They act on wheel events in DoMouseWheel, DoMouseWheelDown or DoMouseWheelUp. For as far I know, no control in the VCL has overriden MouseWheelHandler in order to handle wheel events.
Looking at different applications, there seems to be no conformity on which wheel scroll behaviour is the standard. For example: MS Word scrolls the page that is hovered, MS Excel scrolls the workbook that is focused, Windows Eplorer scrolls the focused pane, websites implement scroll behaviour each very differently, Evernote scrolls the window that is hovered, etc... And Delphi's own IDE tops everything by scrolling the focused window as well as the hovered window, except when hovering the code editor, then the code editor steals focus when you scroll (XE2).
Luckily Microsoft offers at least user experience guidelines for Windows-based desktop applications:
Make the mouse wheel affect the control, pane, or window that the pointer is currently over. Doing so avoids unintended results.
Make the mouse wheel take effect without clicking or having input focus. Hovering is sufficient.
Make the mouse wheel affect the object with the most specific scope. For example, if the pointer is over a scrollable list box control in a scrollable pane within a scrollable window, the mouse wheel affects the list box control.
Don't change the input focus when using the mouse wheel.
So the question's requirement to only scroll the hovered control has enough grounds, but Delphi's developers haven't made it easy to implement it.
Conclusion and solution
The preferred solution is one without subclassing windows or multiple implementations for different forms or controls.
To prevent the focused control from scrolling, the control may not receive the CM_MOUSEWHEEL message. Therefore, MouseWheelHandler of any control may not be called. Therefore, WM_MOUSEWHEEL may not be send to any control. Thus the only place left for intervention is TApplication.OnMessage. Furthermore, the message may not escape from it, so all handling should take place in that event handler and when all default VCL wheel handling is bypassed, every possible condition is to be taken care of.
Let's start simple. The enabled window which currently is hovered is gotten with WindowFromPoint.
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
var
Window: HWND;
begin
if Msg.message = WM_MOUSEWHEEL then
begin
Window := WindowFromPoint(Msg.pt);
if Window <> 0 then
begin
Handled := True;
end;
end;
end;
With FindControl we get a reference to the VCL control. If the result is nil, then the hovered window does not belong to the application's process, or it is a window not known to the VCL (e.g. a dropped down TDateTimePicker). In that case the message needs to be forwarded back to the API, and its result we are not interested in.
WinControl: TWinControl;
WndProc: NativeInt;
WinControl := FindControl(Window);
if WinControl = nil then
begin
WndProc := GetWindowLongPtr(Window, GWL_WNDPROC);
CallWindowProc(Pointer(WndProc), Window, Msg.message, Msg.wParam,
Msg.lParam);
end
else
begin
end;
When the window ís a VCL control, multiple message handlers are to be considered calling, in a specific order. When there is an enabled non-windowed control (of type TControl or descendant) on the mouse position, it first should get a CM_MOUSEWHEEL message because that control is definitely the foreground control. The message is to be constructed from the WM_MOUSEWHEEL message and translated into its VCL equivalent. Secondly, the WM_MOUSEWHEEL message has to be send to the control's DefaultHandler method to allow handling for native controls. And at last, again the CM_MOUSEWHEEL message has to be send to the control when no previous handler took care of the message. These last two steps cannot take place in reversed order because e.g. a memo on a scroll box must be able to scroll too.
Point: TPoint;
Message: TMessage;
Point := WinControl.ScreenToClient(Msg.pt);
Message.WParam := Msg.wParam;
Message.LParam := Msg.lParam;
TCMMouseWheel(Message).ShiftState :=
KeysToShiftState(TWMMouseWheel(Message).Keys);
Message.Result := WinControl.ControlAtPos(Point, False).Perform(
CM_MOUSEWHEEL, Message.WParam, Message.LParam);
if Message.Result = 0 then
begin
Message.Msg := Msg.message;
Message.WParam := Msg.wParam;
Message.LParam := Msg.lParam;
WinControl.DefaultHandler(Message);
end;
if Message.Result = 0 then
begin
Message.WParam := Msg.wParam;
Message.LParam := Msg.lParam;
TCMMouseWheel(Message).ShiftState :=
KeysToShiftState(TWMMouseWheel(Message).Keys);
Message.Result := WinControl.Perform(CM_MOUSEWHEEL, Message.WParam,
Message.LParam);
end;
When a window has captured the mouse, all wheel messages should be sent to it. The window retrieved by GetCapture is ensured to be a window of the current process, but it does not have to be a VCL control. E.g. during a drag operation, a temporary window is created (see TDragObject.DragHandle) that receives mouse messages. All messages? Noooo, WM_MOUSEWHEEL is not sent to the capturing window, so we have to redirect it. Furthermore, when the capturing window does not handle the message, all other previously covered processing should take place. This is a feature which is missing in the VCL: on wheeling during a drag operation, Form.OnMouseWheel indeed is called, but the focused or hovered control does not receive the message. This means for example that a text cannot be dragged into a memo's content on a location that is beyond the visible part of the memo.
Window := GetCapture;
if Window <> 0 then
begin
Message.Result := GetCaptureControl.Perform(CM_MOUSEWHEEL, Message.WParam,
Message.LParam);
if Message.Result = 0 then
Message.Result := SendMessage(Window, Msg.message, Msg.wParam,
Msg.lParam);
end;
This essentially does the job, and it was the basis for the unit presented below. To get it working, just add the unit name to one of the uses clauses in your project. It has the following additional features:
The possibility to preview a wheel action in the main form, the active form, or the active control.
Registration of control classes for which their MouseWheelHandler method has to be called.
The possibility to bring this TApplicationEvents object in front of all others.
The possibility to cancel dispatching the OnMessage event to all other TApplicationEvents objects.
The possibility to still allow for default VCL handling afterwards for analytical or testing purposes.
ScrollAnywhere.pas
unit ScrollAnywhere;
interface
uses
System.Classes, System.Types, System.Contnrs, Winapi.Windows, Winapi.Messages,
Vcl.Controls, Vcl.Forms, Vcl.AppEvnts;
type
TWheelMsgSettings = record
MainFormPreview: Boolean;
ActiveFormPreview: Boolean;
ActiveControlPreview: Boolean;
VclHandlingAfterHandled: Boolean;
VclHandlingAfterUnhandled: Boolean;
CancelApplicationEvents: Boolean;
procedure RegisterMouseWheelHandler(ControlClass: TControlClass);
end;
TMouseHelper = class helper for TMouse
public
class var WheelMsgSettings: TWheelMsgSettings;
end;
procedure Activate;
implementation
type
TWheelInterceptor = class(TCustomApplicationEvents)
private
procedure ApplicationMessage(var Msg: tagMSG; var Handled: Boolean);
public
constructor Create(AOwner: TComponent); override;
end;
var
WheelInterceptor: TWheelInterceptor;
ControlClassList: TClassList;
procedure TWheelInterceptor.ApplicationMessage(var Msg: tagMSG;
var Handled: Boolean);
var
Window: HWND;
WinControl: TWinControl;
WndProc: NativeInt;
Message: TMessage;
OwningProcess: DWORD;
procedure WinWParamNeeded;
begin
Message.WParam := Msg.wParam;
end;
procedure VclWParamNeeded;
begin
TCMMouseWheel(Message).ShiftState :=
KeysToShiftState(TWMMouseWheel(Message).Keys);
end;
procedure ProcessControl(AControl: TControl;
CallRegisteredMouseWheelHandler: Boolean);
begin
if (Message.Result = 0) and CallRegisteredMouseWheelHandler and
(AControl <> nil) and
(ControlClassList.IndexOf(AControl.ClassType) <> -1) then
begin
AControl.MouseWheelHandler(Message);
end;
if Message.Result = 0 then
Message.Result := AControl.Perform(CM_MOUSEWHEEL, Message.WParam,
Message.LParam);
end;
begin
if Msg.message <> WM_MOUSEWHEEL then
Exit;
with Mouse.WheelMsgSettings do
begin
Message.Msg := Msg.message;
Message.WParam := Msg.wParam;
Message.LParam := Msg.lParam;
Message.Result := LRESULT(Handled);
// Allow controls for which preview is set to handle the message
VclWParamNeeded;
if MainFormPreview then
ProcessControl(Application.MainForm, False);
if ActiveFormPreview then
ProcessControl(Screen.ActiveCustomForm, False);
if ActiveControlPreview then
ProcessControl(Screen.ActiveControl, False);
// Allow capturing control to handle the message
Window := GetCapture;
if (Window <> 0) and (Message.Result = 0) then
begin
ProcessControl(GetCaptureControl, True);
if Message.Result = 0 then
Message.Result := SendMessage(Window, Msg.message, Msg.wParam,
Msg.lParam);
end;
// Allow hovered control to handle the message
Window := WindowFromPoint(Msg.pt);
if (Window <> 0) and (Message.Result = 0) then
begin
WinControl := FindControl(Window);
if WinControl = nil then
begin
// Window is a non-VCL window (e.g. a dropped down TDateTimePicker), or
// the window doesn't belong to this process
WndProc := GetWindowLongPtr(Window, GWL_WNDPROC);
Message.Result := CallWindowProc(Pointer(WndProc), Window,
Msg.message, Msg.wParam, Msg.lParam);
end
else
begin
// Window is a VCL control
// Allow non-windowed child controls to handle the message
ProcessControl(WinControl.ControlAtPos(
WinControl.ScreenToClient(Msg.pt), False), True);
// Allow native controls to handle the message
if Message.Result = 0 then
begin
WinWParamNeeded;
WinControl.DefaultHandler(Message);
end;
// Allow windowed VCL controls to handle the message
if not ((MainFormPreview and (WinControl = Application.MainForm)) or
(ActiveFormPreview and (WinControl = Screen.ActiveCustomForm)) or
(ActiveControlPreview and (WinControl = Screen.ActiveControl))) then
begin
VclWParamNeeded;
ProcessControl(WinControl, True);
end;
end;
end;
// Bypass default VCL wheel handling?
Handled := ((Message.Result <> 0) and not VclHandlingAfterHandled) or
((Message.Result = 0) and not VclHandlingAfterUnhandled);
// Modify message destination for current process
if (not Handled) and (Window <> 0) and
(GetWindowThreadProcessID(Window, OwningProcess) <> 0) and
(OwningProcess = GetCurrentProcessId) then
begin
Msg.hwnd := Window;
end;
if CancelApplicationEvents then
CancelDispatch;
end;
end;
constructor TWheelInterceptor.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
OnMessage := ApplicationMessage;
end;
procedure Activate;
begin
WheelInterceptor.Activate;
end;
{ TWheelMsgSettings }
procedure TWheelMsgSettings.RegisterMouseWheelHandler(
ControlClass: TControlClass);
begin
ControlClassList.Add(ControlClass);
end;
initialization
ControlClassList := TClassList.Create;
WheelInterceptor := TWheelInterceptor.Create(Application);
finalization
ControlClassList.Free;
end.
Disclaimer:
This code intentionally does not scroll anything, it only prepares the message routing for VCL's OnMouseWheel* events to get the proper opportunity to get fired. This code is not tested on third-party controls. When VclHandlingAfterHandled or VclHandlingAfterUnhandled is set True, then mouse events may be fired twice. In this post I made some claims and I considered there to be three bugs in the VCL, however, that is all based on studying documentation and testing. Please do test this unit and comment on findings and bugs. I apologize for this rather long answer; I simply do not have a blog.
1) Naming cheeky taken from A Key’s Odyssey
2) See my Quality Central bug report #135258
3) See my Quality Central bug report #135305
Try overriding your form's MouseWheelHandler method like this (I have not tested this thoroughly):
procedure TMyForm.MouseWheelHandler(var Message: TMessage);
var
Control: TControl;
begin
Control := ControlAtPos(ScreenToClient(SmallPointToPoint(TWMMouseWheel(Message).Pos)), False, True, True);
if Assigned(Control) and (Control <> ActiveControl) then
begin
Message.Result := Control.Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);
if Message.Result = 0 then
Control.DefaultHandler(Message);
end
else
inherited MouseWheelHandler(Message);
end;
Override the TApplication.OnMessage event (or create a
TApplicationEvents component) and redirect the WM_MOUSEWHEEL message in
the event handler:
procedure TMyForm.AppEventsMessage(var Msg: tagMSG;
var Handled: Boolean);
var
Pt: TPoint;
C: TWinControl;
begin
if Msg.message = WM_MOUSEWHEEL then begin
Pt.X := SmallInt(Msg.lParam);
Pt.Y := SmallInt(Msg.lParam shr 16);
C := FindVCLWindow(Pt);
if C = nil then
Handled := True
else if C.Handle <> Msg.hwnd then begin
Handled := True;
SendMessage(C.Handle, WM_MOUSEWHEEL, Msg.wParam, Msg.lParam);
end;
end;
end;
It works fine here, though you may want to add some protection to keep
it from recursing if something unexpected happens.
You might find this article useful: send a scroll down message to listbox using mousewheel, but listbox doesn't have focus [1], it is written in C#, but converting to Delphi shouldn't be too big a problem. It uses hooks to accomplish the wanted effect.
To find out which component the mouse is currently over, you can use the FindVCLWindow function, an example of this can be found in this article: Get the Control Under the Mouse in a Delphi application [2].
[1] http://social.msdn.microsoft.com/forums/en-US/winforms/thread/ec1fbfa2-137e-49f6-b444-b634e4f44f21/
[2] http://delphi.about.com/od/delphitips2008/qt/find-vcl-window.htm
This is the solution I've been using:
Add amMouseWheel to the uses clause of the implementation section of the unit of your form after the forms unit:
unit MyUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
// Fix and util for mouse wheel
amMouseWheel;
...
Save the following code to amMouseWheel.pas:
unit amMouseWheel;
// -----------------------------------------------------------------------------
// The original author is Anders Melander, anders#melander.dk, http://melander.dk
// Copyright © 2008 Anders Melander
// -----------------------------------------------------------------------------
// License:
// Creative Commons Attribution-Share Alike 3.0 Unported
// http://creativecommons.org/licenses/by-sa/3.0/
// -----------------------------------------------------------------------------
interface
uses
Forms,
Messages,
Classes,
Controls,
Windows;
//------------------------------------------------------------------------------
//
// TForm work around for mouse wheel messages
//
//------------------------------------------------------------------------------
// The purpose of this class is to enable mouse wheel messages on controls
// that doesn't have the focus.
//
// To scroll with the mouse just hover the mouse over the target control and
// scroll the mouse wheel.
//------------------------------------------------------------------------------
type
TForm = class(Forms.TForm)
public
procedure MouseWheelHandler(var Msg: TMessage); override;
end;
//------------------------------------------------------------------------------
//
// Generic control work around for mouse wheel messages
//
//------------------------------------------------------------------------------
// Call this function from a control's (e.g. a TFrame) DoMouseWheel method like
// this:
//
// function TMyFrame.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
// MousePos: TPoint): Boolean;
// begin
// Result := ControlDoMouseWheel(Self, Shift, WheelDelta, MousePos) or inherited;
// end;
//
//------------------------------------------------------------------------------
function ControlDoMouseWheel(Control: TControl; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint): Boolean;
implementation
uses
Types;
procedure TForm.MouseWheelHandler(var Msg: TMessage);
var
Target: TControl;
begin
// Find the control under the mouse
Target := FindDragTarget(SmallPointToPoint(TCMMouseWheel(Msg).Pos), False);
while (Target <> nil) do
begin
// If the target control is the focused control then we abort as the focused
// control is the originator of the call to this method.
if (Target = Self) or ((Target is TWinControl) and (TWinControl(Target).Focused)) then
begin
Target := nil;
break;
end;
// Let the target control process the scroll. If the control doesn't handle
// the scroll then...
Msg.Result := Target.Perform(CM_MOUSEWHEEL, Msg.WParam, Msg.LParam);
if (Msg.Result <> 0) then
break;
// ...let the target's parent give it a go instead.
Target := Target.Parent;
end;
// Fall back to the default processing if none of the controls under the mouse
// could handle the scroll.
if (Target = nil) then
inherited;
end;
type
TControlCracker = class(TControl);
function ControlDoMouseWheel(Control: TControl; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint): Boolean;
var
Target: TControl;
begin
(*
** The purpose of this method is to enable mouse wheel messages on controls
** that doesn't have the focus.
**
** To scroll with the mouse just hover the mouse over the target control and
** scroll the mouse wheel.
*)
Result := False;
// Find the control under the mouse
Target := FindDragTarget(MousePos, False);
while (not Result) and (Target <> nil) do
begin
// If the target control is the focused control then we abort as the focused
// control is the originator of the call to this method.
if (Target = Control) or ((Target is TWinControl) and (TWinControl(Target).Focused)) then
break;
// Let the target control process the scroll. If the control doesn't handle
// the scroll then...
Result := TControlCracker(Target).DoMouseWheel(Shift, WheelDelta, MousePos);
// ...let the target's parent give it a go instead.
Target := Target.Parent;
end;
end;
end.
I had the same problem and solved it with some little hack, but it works.
I didn't want to mess around with messages and decided just to call DoMouseWheel method to control I need. Hack is that DoMouseWheel is protected method and therefore not accessible from form unit file, that's why I defined my class in form unit:
TControlHack = class(TControl)
end; //just to call DoMouseWheel
Then I wrote TForm1.onMouseWheel event handler:
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var i: Integer;
c: TControlHack;
begin
for i:=0 to ComponentCount-1 do
if Components[i] is TControl then begin
c:=TControlHack(Components[i]);
if PtInRect(c.ClientRect,c.ScreenToClient(MousePos)) then
begin
Handled:=c.DoMouseWheel(shift,WheelDelta,MousePos);
if Handled then break;
end;
end;
end;
As you see, it search for all the controls on form, not only immediate children, and turns out to search from parents to children. It would be better (but more code) to make recursive search at children, but code above works just fine.
To make only one control respond to mousewheel event, you should always set Handled:=true when it's implemented. If for example you have listbox inside panel, then panel will execute DoMouseWheel first, and if it didn't handle event, listbox.DoMouseWheel will execute. If no control under mouse cursor handled DoMouseWheel, the focused control will, it seems rather adequate behavior.
Only for using with DevExpress controls
It works on XE3. It was not tested on other versions.
procedure TMainForm.DoApplicationMessage(var AMsg: TMsg; var AHandled: Boolean);
var
LControl: TWinControl;
LMessage: TMessage;
begin
if AMsg.message <> WM_MOUSEWHEEL then
Exit;
LControl := FindVCLWindow(AMsg.pt);
if not Assigned(LControl) then
Exit;
LMessage.WParam := AMsg.wParam;
// see TControl.WMMouseWheel
TCMMouseWheel(LMessage).ShiftState := KeysToShiftState(TWMMouseWheel(LMessage).Keys);
LControl.Perform(CM_MOUSEWHEEL, LMessage.WParam, AMsg.lParam);
AHandled := True;
end;
if you don't use DevExpress controls, then Perform -> SendMessage
SendMessage(LControl.Handle, AMsg.message, AMsg.WParam, AMsg.lParam);
In the OnMouseEnter event for each scrollable control add a respective call to SetFocus
So for ListBox1:
procedure TForm1.ListBox1MouseEnter(Sender: TObject);
begin
ListBox1.SetFocus;
end;
Does this achieve the desired effect?