TControl的消息覆盖函数大全（15个WM_函数和17个CM_函数，它的WndProc就处理鼠标与键盘消息）

Posted 2020-07-01 朝闻道

注意，这些函数只有Private一种形式（也就是不允许覆盖，但仍在动态表格中）：

  TControl = class(TComponent)
  private
    // 15个私有消息处理，大多是鼠标消息。注意，消息函数大多只是一个中介，且TWinControl并不重写。
    procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
    procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;
    procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
    procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP;
    //
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
    procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED; // 重新计算最大化最小化的限制和坞里的尺寸
    procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU; // 真正展开右键菜单，其子类虽然覆盖这个函数，但反而只是帮助发送而已（发送给图形控件，为其增加右键菜单功能）。
    // 17个组件事件（大多是简单函数，通知某件事情，一般没有实际内容）
    // CM_显示函数
    procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED; // 显示属性被改变了，那么要调用InvalidateControl重画自己。fixme 不明白这句为什么一定要这样调用，而不是执行Invalidate函数
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; // 3个函数都简单调用Invalidate; 但是注意，它有可能调用子类TWinControl的Invalidate函数
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
    procedure CMParentBiDiModeChanged(var Message: TMessage); message CM_PARENTBIDIMODECHANGED;
    // 颜色字体
    procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
    procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED;  // 调用SetFont
    procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
    procedure CMParentShowHintChanged(var Message: TMessage); message CM_PARENTSHOWHINTCHANGED; // 调用 SetShowHint
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
    procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST; // 测试鼠标消息对子控件是否起作用
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; // important 有趣，给父控件发送CM_MOUSEENTER，为什么要依赖它来处理？
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST; // important5 什么都不做，消息结果为未处理
    procedure CMFloat(var Message: TCMFloat); message CM_FLOAT;
    procedure CMMouseWheel(var Message: TCMMouseWheel); message CM_MOUSEWHEEL; // 给父控件发送CM_MOUSEWHEEL
end;

同时把它的WndProc列出来，这样它能处理的消息就齐了：

procedure TControl.WndProc(var Message: TMessage);
var
  Form: TCustomForm;
  KeyState: TKeyboardState;
  WheelMsg: TCMMouseWheel;
begin  
  if (csDesigning in ComponentState) then
  begin
    Form := GetParentForm(Self);
    if (Form <> nil) and (Form.Designer <> nil) and
      Form.Designer.IsDesignMsg(Self, Message) then Exit //消息由窗体来处理
  end;
  //窗体可以为其拥有的组件来处理键盘消息
  if (Message.Msg >= WM_KEYFIRST) and (Message.Msg <= WM_KEYLAST) then
  begin
    Form := GetParentForm(Self);
    if (Form <> nil) and Form.WantChildKey(Self, Message) then Exit;
  end
  // important 图形控件的鼠标处理都在这里
  else if (Message.Msg >= WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST) then
  begin
    //如果组件不可以接受和处理双击消息，就将双击消息映射为单击消息。
    if not (csDoubleClicks in ControlStyle) then
      case Message.Msg of
        WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK:
          Dec(Message.Msg, WM_LBUTTONDBLCLK - WM_LBUTTONDOWN);
      end;
    case Message.Msg of
      WM_MOUSEMOVE:
        Application.HintMouseMessage(Self, Message); // 如果是鼠标移动的消息，则出现hint窗口
      WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: // 如果是左键被按下，或者双击，如果是自动拖动模式，则开始拖动，并将左键按下的状态加入组件的状态。
        begin
          if FDragMode = dmAutomatic then
          begin
            BeginAutoDrag;
            Exit;
          end;
          Include(FControlState, csLButtonDown); // important 为图形控件(也可为Win控件)增加鼠标点击状态。点击Button就会执行到这里来。
        end;
      WM_LBUTTONUP:
        Exclude(FControlState, csLButtonDown); //如果是左键放开，则将左键按下的状态剔除。
    else
      with Mouse do
        if WheelPresent and (RegWheelMessage <> 0) and //如果鼠标有滚轮，并且滚轮滑动时发出了消息
          (Message.Msg = RegWheelMessage) then
        begin
          GetKeyboardState(KeyState); // API，将256虚拟键的状态拷贝到缓存中去
          with WheelMsg do //填充记录
          begin
            Msg := Message.Msg;
            ShiftState := KeyboardStateToShiftState(KeyState);
            WheelDelta := Message.WParam;
            Pos := TSmallPoint(Message.LParam);
          end;
          MouseWheelHandler(TMessage(WheelMsg)); // 类函数，派发鼠标滚轮的消息
          Exit;
        end;
    end;
  end
  else if Message.Msg = CM_VISIBLECHANGED then
    with Message do
      SendDockNotification(Msg, WParam, LParam);
  Dispatch(Message); // 到了这里，已经无法再使用WndProc方法向父类传递消息了，所以使用Dispatch。而且必定向上传递（一般情况下TControl的父类不会不响应这些消息）
end;