如何为从 TGraphicControl 继承的组件添加鼠标滚轮支持?

本文介绍了如何为从 TGraphicControl 继承的组件添加鼠标滚轮支持?的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！ 问题描述 29岁程序员，3月因学历无情被辞！ 我创建了一个源自 TGraphicControl 的 delphi 组件.是否可以添加对鼠标滚轮的支持?--- 编辑---我已经公开了如下所示的 MouseWheel 事件，但它们没有被调用.TMyComponent = class(TGraphicControl)发表属性 OnMouseWheel;属性 OnMouseWheelDown;属性 OnMouseWheelUp;结尾;--- 编辑---如下所述，我尝试捕获 WM_MOUSEWHEEL 和 CM_MOUSEWHEEL 消息，但似乎不起作用.但是我设法捕获了 CM_MOUSEENTER 消息.我不明白为什么我可以捕获一种类型的消息，而不能捕获另一种类型的消息. 解决方案 由于多个 VCL 构造(无论它们是故意的实现选择还是可能是错误，我在中间留下)只有获得焦点的控件及其所有父级会收到鼠标滚轮消息，以及捕获鼠标和具有焦点父级的控件.在 TControl 级别，可以强制执行后一个条件.当鼠标进入控件的客户空间时，控件会从 VCL 收到 CM_MOUSEENTER 消息.要强制它接收鼠标滚轮消息，请关注其父级并在该消息处理程序中捕获鼠标:procedure TWheelControl.CMMouseEnter(var Message: TMessage);开始FPrevFocusWindow := SetFocus(Parent.Handle);鼠标捕捉:=真；遗传;结尾;但是这些设置必须在鼠标退出控件时撤消.由于控件现在正在捕获鼠标，CM_MOUSELEAVE 没有被它接收到，所以你必须手动检查这一点，例如在 WM_MOUSEMOVE 消息处理程序中:procedure TWheelControl.WMMouseMove(var Message: TWMMouseMove);开始如果 MouseCapture 和不是 PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) 然后开始鼠标捕获:= 错误；SetFocus(FPrevFocusWindow);结尾;遗传;结尾;现在，您假设控件接收到的滚轮消息随后将触发 OnMouseWheel、OnMouseWheelDown 和 OnMouseWheelUp 事件.但是不，还需要再进行一次干预.消息进入 MouseWheelHandler 中的控件，它恰好将消息传递给窗体或活动控件.要触发这些事件，应发送 CM_MOUSEWHEEL 控制消息:procedure TWheelControl.MouseWheelHandler(var Message: TMessage);开始Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);如果 Message.Result = 0 那么继承 MouseWheelHandler(Message);结尾;最终代码如下:unit WheelControl;界面用途System.Classes、Winapi.Windows、Winapi.Messages、Vcl.Controls；类型TWheelControl = 类(TGraphicControl)私人的FPrevFocusWindow:HWND；过程 CMMouseEnter(var Message: TMessage);消息 CM_MOUSEENTER;过程 WMMouseMove(var 消息:TWMMouseMove)；消息 WM_MOUSEMOVE;上市过程 MouseWheelHandler(var Message: TMessage);覆盖；发表属性 OnMouseWheel;属性 OnMouseWheelDown;属性 OnMouseWheelUp;结尾;执行{ TWheelControl }程序 TWheelControl.CMMouseEnter(var Message: TMessage);开始FPrevFocusWindow := SetFocus(Parent.Handle);鼠标捕捉:=真；遗传;结尾;过程 TWheelControl.MouseWheelHandler(var Message: TMessage);开始Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam);如果 Message.Result = 0 那么继承 MouseWheelHandler(Message);结尾;过程 TWheelControl.WMMouseMove(var Message: TWMMouseMove);开始如果 MouseCapture 和不是 PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) 然后开始鼠标捕获:= 错误；SetFocus(FPrevFocusWindow);结尾;遗传;结尾;结尾.如您所见，这会更改焦点控件，这与 基于 Windows 的桌面应用程序的用户体验指南，当焦点控件具有明确的焦点状态时，可能会导致视觉干扰.作为替代方案，您可以通过覆盖 Application.OnMessage 并在那里处理它来绕过所有默认的 VCL 鼠标滚轮处理.这可以按如下方式完成:unit WheelControl2;界面用途System.Classes、Winapi.Windows、Winapi.Messages、Vcl.Controls、Vcl.AppEvnts、Vcl.Forms;类型TWheelControl = 类(TGraphicControl)发表属性 OnMouseWheel;属性 OnMouseWheelDown;属性 OnMouseWheelUp;结尾;执行类型TWheelInterceptor = class(TCustomApplicationEvents)私人的过程 ApplicationMessage(var Msg: tagMSG; var Handled: Boolean);上市构造函数创建(AOwner:TComponent)；覆盖；结尾;过程 TWheelInterceptor.ApplicationMessage(var Msg: tagMSG;处理的变量:布尔值)；无功窗口:HWND；WinControl:双控；控制:TControl；消息:TMessage；开始如果 Msg.message = WM_MOUSEWHEEL 那么开始窗口 := WindowFromPoint(Msg.pt);如果窗口 <>0 那么开始WinControl := FindControl(Window);如果 WinControl <>零然后开始控制 := WinControl.ControlAtPos(WinControl.ScreenToClient(Msg.pt),错误的);如果控制零然后开始Message.WParam := Msg.wParam;Message.LParam := Msg.lParam;TCMMouseWheel(Message).ShiftState :=KeysToShiftState(TWMMouseWheel(Message).Keys);Message.Result := Control.Perform(CM_MOUSEWHEEL, Message.WParam,Message.LParam);已处理:= Message.Result <>0;结尾;结尾;结尾;结尾;结尾;构造函数 TWheelInterceptor.Create(AOwner: TComponent);开始继承创建(AOwner)；OnMessage := ApplicationMessage;结尾;初始化TWheelInterceptor.Create(Application);结尾.注意将MouseWheel*事件的Handled参数设置为True，否则焦点控件也会滚动.>另请参阅如何将鼠标滚轮输入定向到光标下控制而不是聚焦?了解更多有关鼠标滚轮的背景信息处理和更通用的解决方案. 参见 质量中心错误报告 #135258 和 质量中心错误报告 #135305.I have created a delphi component which descends from TGraphicControl. Is it possible to add support for mouse wheels?--- Edit ---I've exposed the MouseWheel events as shown below but they aren't called. TMyComponent = class(TGraphicControl)published property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp;end;--- Edit ---As suggested below, I've tried to trap the WM_MOUSEWHEEL and CM_MOUSEWHEEL messages, but it doesn't seem to work. However I've managed to trap the CM_MOUSEENTER message. I don't understand why i can trap one type of message, but not the other. 解决方案 Due to several VCL constructs (whether they are deliberate implementation choices or may possibly be bugs, I leave in the middle) only the focused control and all its parents get mouse wheel messages, as well as the control which has the mouse captured ánd has a focused parent.At the TControl level, the latter condition can be enforced. A control receives a CM_MOUSEENTER message from the VCL when the mouse enters the client space of the control. To force it to receive mouse wheel messages, focus its parent and capture the mouse in that message handler:procedure TWheelControl.CMMouseEnter(var Message: TMessage);begin FPrevFocusWindow := SetFocus(Parent.Handle); MouseCapture := True; inherited;end;But these settings must be undone when the mouse exits the control. Since the control is now capturing the mouse, CM_MOUSELEAVE is not received by it, so you have to manually check this, for example in the WM_MOUSEMOVE message handler:procedure TWheelControl.WMMouseMove(var Message: TWMMouseMove);begin if MouseCapture and not PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then begin MouseCapture := False; SetFocus(FPrevFocusWindow); end; inherited;end;Now, you would assume the wheel messages received by the control will subsequently fire the OnMouseWheel, OnMouseWheelDown and OnMouseWheelUp events. But noooo, one more intervention is needed. The message enters the control in MouseWheelHandler which happens to pass the message on to either the form or active control. To get these events fired, a CM_MOUSEWHEEL control message should be sent:procedure TWheelControl.MouseWheelHandler(var Message: TMessage);begin Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam); if Message.Result = 0 then inherited MouseWheelHandler(Message);end;Which results in this final code:unit WheelControl;interfaceuses System.Classes, Winapi.Windows, Winapi.Messages, Vcl.Controls;type TWheelControl = class(TGraphicControl) private FPrevFocusWindow: HWND; procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; public procedure MouseWheelHandler(var Message: TMessage); override; published property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; end;implementation{ TWheelControl }procedure TWheelControl.CMMouseEnter(var Message: TMessage);begin FPrevFocusWindow := SetFocus(Parent.Handle); MouseCapture := True; inherited;end;procedure TWheelControl.MouseWheelHandler(var Message: TMessage);begin Message.Result := Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam); if Message.Result = 0 then inherited MouseWheelHandler(Message);end;procedure TWheelControl.WMMouseMove(var Message: TWMMouseMove);begin if MouseCapture and not PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then begin MouseCapture := False; SetFocus(FPrevFocusWindow); end; inherited;end;end.As you see, this changes the focused control, which is against the user experience guidelines for Windows-based desktop applications and might result in visual distractions when the focused control had an explicit focused state.As an alternative, you can bypass all default VCL mouse wheel handling by overriding Application.OnMessage and deal with it there. This might be done as follows:unit WheelControl2;interfaceuses System.Classes, Winapi.Windows, Winapi.Messages, Vcl.Controls, Vcl.AppEvnts, Vcl.Forms;type TWheelControl = class(TGraphicControl) published property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; end;implementationtype TWheelInterceptor = class(TCustomApplicationEvents) private procedure ApplicationMessage(var Msg: tagMSG; var Handled: Boolean); public constructor Create(AOwner: TComponent); override; end;procedure TWheelInterceptor.ApplicationMessage(var Msg: tagMSG; var Handled: Boolean);var Window: HWND; WinControl: TWinControl; Control: TControl; Message: TMessage;begin if Msg.message = WM_MOUSEWHEEL then begin Window := WindowFromPoint(Msg.pt); if Window <> 0 then begin WinControl := FindControl(Window); if WinControl <> nil then begin Control := WinControl.ControlAtPos(WinControl.ScreenToClient(Msg.pt), False); if Control <> nil then begin Message.WParam := Msg.wParam; Message.LParam := Msg.lParam; TCMMouseWheel(Message).ShiftState := KeysToShiftState(TWMMouseWheel(Message).Keys); Message.Result := Control.Perform(CM_MOUSEWHEEL, Message.WParam, Message.LParam); Handled := Message.Result <> 0; end; end; end; end;end;constructor TWheelInterceptor.Create(AOwner: TComponent);begin inherited Create(AOwner); OnMessage := ApplicationMessage;end;initialization TWheelInterceptor.Create(Application);end.Be careful to set the Handled parameter of the MouseWheel* event to True, otherwise the focused control will scroll as well.See also How to direct the mouse wheel input to control under cursor instead of focused? for more background on mouse wheel handling and a more general solution. See Quality Central bug report #135258, and Quality Central bug report #135305. 这篇关于如何为从 TGraphicControl 继承的组件添加鼠标滚轮支持?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！ 上岸，阿里云！