使控件支持鼠标滚轴消息 TScrollBox的BUG

Bear_hx 2008-04-09 01:07:52

使控件支持鼠标滚轴消息
这几天要写一个控件，要求能支持鼠标滚轴放大缩小，类似网页上的Google地图。于是我从TWinControl下继承，重写



function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;

function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;

function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;

但是发现程序在运行的时候只有窗体能得到滚轴消息，控件本身不能，于是想到窗体是整个这个窗体上控件的消息管理者，是不是它过滤了，果然发现：



procedure TCustomForm.MouseWheelHandler(var Message: TMessage);

begin

  with Message do

  begin

    if FFocusedControl <> nil then

      Result := FFocusedControl.Perform(CM_MOUSEWHEEL, WParam, LParam)

    else

      inherited MouseWheelHandler(Message);

  end;

end;

结果是鼠标消息的被主窗体过滤为只发给有焦点的控件（这是合理的），于是想到TCustomForm设置焦点的函数：



procedure TCustomForm.SetActive(Value: Boolean);

begin

  FActive := Value;

  if FActiveOleControl <> nil then

    FActiveOleControl.Perform(CM_DOCWINDOWACTIVATE, Ord(Value), 0);

  if Value then

  begin

    if (ActiveControl = nil) and not (csDesigning in ComponentState) then

      ActiveControl := FindNextControl(nil, True, True, False);

    MergeMenu(True);

    SetWindowFocus;

  end;

end;

发现主要控制是由FindNextControl来寻找来设置焦点的控件，这个函数是在TWinControl中



function TWinControl.FindNextControl(CurControl: TWinControl;

  GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;

var

  I, StartIndex: Integer;

  List: TList;

begin

  Result := nil;

  List := TList.Create;

  try

    GetTabOrderList(List);

    if List.Count > 0 then

    begin

      StartIndex := List.IndexOf(CurControl);

      if StartIndex = -1 then

        if GoForward then StartIndex := List.Count - 1 else StartIndex := 0;

      I := StartIndex;

      repeat

        if GoForward then

        begin

          Inc(I);

          if I = List.Count then I := 0;

        end else

        begin

          if I = 0 then I := List.Count;

          Dec(I);

        end;

        CurControl := List[I];

        if CurControl.CanFocus and

          (not CheckTabStop or CurControl.TabStop) and

          (not CheckParent or (CurControl.Parent = Self)) then

          Result := CurControl;

      until (Result <> nil) or (I = StartIndex);

    end;

  finally

    List.Free;

  end;

end;

细看代码发现主要是



  if CurControl.CanFocus and

          (not CheckTabStop or CurControl.TabStop) and

          (not CheckParent or (CurControl.Parent = Self)) then

          Result := CurControl;

在控制，其中(not CheckTabStop or CurControl.TabStop)最重要，因此如果控件在创建的时候没有设置TabStop为True的话，那么窗体就认为控件不能获得焦点，也就不会发送CM_MOUSEWHEEL给控件，至此问题解决，只要在构造函数中把TabStop := True加上，然后重载



function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;

function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;

function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;

就可以使控件支持鼠标滚轴消息了。
题外话：其实VCL对Windows消息进行了封装，而且加了很多自定义消息，也加了一套分发消息的规则，大家在写控件的时候要注意TCustomForm这个类中分发消息的一些规则。这个的典型例子是TScrollBox，有滚动条，却不支持鼠标滚轴消息，即使写了property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp;也不能截获消息，这是VCL的BUG,其实就是没设置TabStop为真。
Bear_hx 樊升 2008-4-2

...全文