娃娃鸭深入核心VCL架构剖析(李维)笔记

 

40、VCL组件和窗口控件的结合

constructor TWinControl.Create(AOwner: TComponent); begin … FObjectInstance := Classes.MakeObjectInstance(MainWndProc); … end; function MakeObjectInstance(Method: TWndMethod): Pointer; const   BlockCode: array[1..2] of Byte = (     $59,       { POP ECX }     $E9);      { JMP StdWndProc }   PageSize = 4096; var   Block: PInstanceBlock;   Instance: PObjectInstance; begin   if InstFreeList = nil then   begin     Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);     Block^.Next := InstBlockList;     Move(BlockCode, Block^.Code, SizeOf(BlockCode));     Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));     Instance := @Block^.Instances;     repeat       Instance^.Code := $E8;  { CALL NEAR PTR Offset }       Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);       Instance^.Next := InstFreeList;       InstFreeList := Instance;       Inc(Longint(Instance), SizeOf(TObjectInstance));     until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);     InstBlockList := Block;   end;   Result := InstFreeList;   Instance := InstFreeList;   InstFreeList := Instance^.Next;   Instance^.Method := Method; end;   type   PInstanceBlock = ^TInstanceBlock;   TInstanceBlock = packed record     Next: PInstanceBlock;     Code: array[1..2] of Byte;     WndProcPtr: Pointer;     Instances: array[0..InstanceCount] of TObjectInstance;   end;

 

41、VCL Framework的自定义消息

VCL Framework之中的自定义消息主要分成两类： ·VCL控件消息 ·VCL控件通知消息 VCL控件消息主要是映对相关的窗口消息，而VCL控件通知消息则是用来在VCL类中相互通知发生的事件的。 VCL控件消息： const   CM_BASE                   = $B000;   CM_ACTIVATE               = CM_BASE + 0;   CM_DEACTIVATE             = CM_BASE + 1;   CM_GOTFOCUS               = CM_BASE + 2;   CM_LOSTFOCUS              = CM_BASE + 3;   CM_CANCELMODE             = CM_BASE + 4;   CM_DIALOGKEY              = CM_BASE + 5;   CM_DIALOGCHAR             = CM_BASE + 6;   CM_FOCUSCHANGED           = CM_BASE + 7;   CM_PARENTFONTCHANGED      = CM_BASE + 8;   CM_PARENTCOLORCHANGED     = CM_BASE + 9;   CM_HITTEST                = CM_BASE + 10;   CM_VISIBLECHANGED         = CM_BASE + 11;   CM_ENABLEDCHANGED         = CM_BASE + 12;   CM_COLORCHANGED           = CM_BASE + 13;   CM_FONTCHANGED            = CM_BASE + 14;   CM_CURSORCHANGED          = CM_BASE + 15;   CM_CTL3DCHANGED           = CM_BASE + 16;   CM_PARENTCTL3DCHANGED     = CM_BASE + 17;   CM_TEXTCHANGED            = CM_BASE + 18;   CM_MOUSEENTER             = CM_BASE + 19;   CM_MOUSELEAVE             = CM_BASE + 20;   CM_MENUCHANGED            = CM_BASE + 21;   CM_APPKEYDOWN             = CM_BASE + 22;   CM_APPSYSCOMMAND          = CM_BASE + 23;   CM_BUTTONPRESSED          = CM_BASE + 24;   CM_SHOWINGCHANGED         = CM_BASE + 25;   CM_ENTER                  = CM_BASE + 26;   CM_EXIT                   = CM_BASE + 27;   CM_DESIGNHITTEST          = CM_BASE + 28;   CM_ICONCHANGED            = CM_BASE + 29;   CM_WANTSPECIALKEY         = CM_BASE + 30;   CM_INVOKEHELP             = CM_BASE + 31;   CM_WINDOWHOOK             = CM_BASE + 32;   CM_RELEASE                = CM_BASE + 33;   CM_SHOWHINTCHANGED        = CM_BASE + 34;   CM_PARENTSHOWHINTCHANGED  = CM_BASE + 35;   CM_SYSCOLORCHANGE         = CM_BASE + 36;   CM_WININICHANGE           = CM_BASE + 37;   CM_FONTCHANGE             = CM_BASE + 38;   CM_TIMECHANGE             = CM_BASE + 39;   CM_TABSTOPCHANGED         = CM_BASE + 40;   CM_UIACTIVATE             = CM_BASE + 41;   CM_UIDEACTIVATE           = CM_BASE + 42;   CM_DOCWINDOWACTIVATE      = CM_BASE + 43;   CM_CONTROLLISTCHANGE      = CM_BASE + 44;   CM_GETDATALINK            = CM_BASE + 45;   CM_CHILDKEY               = CM_BASE + 46;   CM_DRAG                   = CM_BASE + 47;   CM_HINTSHOW               = CM_BASE + 48;   CM_DIALOGHANDLE           = CM_BASE + 49;   CM_ISTOOLCONTROL          = CM_BASE + 50;   CM_RECREATEWND            = CM_BASE + 51;   CM_INVALIDATE             = CM_BASE + 52;   CM_SYSFONTCHANGED         = CM_BASE + 53;   CM_CONTROLCHANGE          = CM_BASE + 54;   CM_CHANGED                = CM_BASE + 55;   CM_DOCKCLIENT             = CM_BASE + 56;   CM_UNDOCKCLIENT           = CM_BASE + 57;   CM_FLOAT                  = CM_BASE + 58;   CM_BORDERCHANGED          = CM_BASE + 59;   CM_BIDIMODECHANGED        = CM_BASE + 60;   CM_PARENTBIDIMODECHANGED  = CM_BASE + 61;   CM_ALLCHILDRENFLIPPED     = CM_BASE + 62;   CM_ACTIONUPDATE           = CM_BASE + 63;   CM_ACTIONEXECUTE          = CM_BASE + 64;   CM_HINTSHOWPAUSE          = CM_BASE + 65;   CM_DOCKNOTIFICATION       = CM_BASE + 66;   CM_MOUSEWHEEL             = CM_BASE + 67;   CM_ISSHORTCUT             = CM_BASE + 68; {$IFDEF LINUX}   CM_RAWX11EVENT            = CM_BASE + 69; {$ENDIF} VCL控件通知消息： { VCL control notification IDs }   const   CN_BASE              = $BC00;   CN_CHARTOITEM        = CN_BASE + WM_CHARTOITEM;   CN_COMMAND           = CN_BASE + WM_COMMAND;   CN_COMPAREITEM       = CN_BASE + WM_COMPAREITEM;   CN_CTLCOLORBTN       = CN_BASE + WM_CTLCOLORBTN;   CN_CTLCOLORDLG       = CN_BASE + WM_CTLCOLORDLG;   CN_CTLCOLOREDIT      = CN_BASE + WM_CTLCOLOREDIT;   CN_CTLCOLORLISTBOX   = CN_BASE + WM_CTLCOLORLISTBOX;   CN_CTLCOLORMSGBOX    = CN_BASE + WM_CTLCOLORMSGBOX;   CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR;   CN_CTLCOLORSTATIC    = CN_BASE + WM_CTLCOLORSTATIC;   CN_DELETEITEM        = CN_BASE + WM_DELETEITEM;   CN_DRAWITEM          = CN_BASE + WM_DRAWITEM;   CN_HSCROLL           = CN_BASE + WM_HSCROLL;   CN_MEASUREITEM       = CN_BASE + WM_MEASUREITEM;   CN_PARENTNOTIFY      = CN_BASE + WM_PARENTNOTIFY;   CN_VKEYTOITEM        = CN_BASE + WM_VKEYTOITEM;   CN_VSCROLL           = CN_BASE + WM_VSCROLL;   CN_KEYDOWN           = CN_BASE + WM_KEYDOWN;   CN_KEYUP             = CN_BASE + WM_KEYUP;   CN_CHAR              = CN_BASE + WM_CHAR;   CN_SYSKEYDOWN        = CN_BASE + WM_SYSKEYDOWN;   CN_SYSCHAR           = CN_BASE + WM_SYSCHAR;   CN_NOTIFY            = CN_BASE + WM_NOTIFY;

 

42、TButton类

TButtonControl = class(TWinControl)   private FClicksDisabled: Boolean; …   protected    procedure WndProc(var Message: TMessage); override; … end; procedure TButtonControl.WndProc(var Message: TMessage); begin   case Message.Msg of     WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:       if not (csDesigning in ComponentState) and not Focused then       begin         FClicksDisabled := True;         Windows.SetFocus(Handle);         FClicksDisabled := False;         if not Focused then Exit;       end;     CN_COMMAND:       if FClicksDisabled then Exit;   end;   inherited WndProc(Message);//不处理的消息提交给父类处理 end; TButton = class(TButtonControl)   private … protected procedure CreateParams(var Params: TCreateParams); override; … end; 每个不同的VCL组件类都必须重载CreateParams方法。 procedure TButton.CreateParams(var Params: TCreateParams); const   ButtonStyles: array[Boolean] of DWORD = (BS_PUSHBUTTON, BS_DEFPUSHBUTTON); begin   inherited CreateParams(Params);   CreateSubClass(Params, 'BUTTON');   Params.Style := Params.Style or ButtonStyles[FDefault]; end; 由于TButton是属于主窗体的组件，因此窗口触发的WM_COMMAND窗口消息会调用主窗体的MainWndProc函数来处理，这就是TWinCtorl.MainWndProc。TWinCtorl.MainWndProc会调用TForm.WndProc虚拟方法来处理窗口消息，由于TForm.WndProc没有处理WM_COMMAND窗口消息，因此TForm.WndProc又会调用TCustomForm.WndProc来处理，而TCustom.WndProc调用了TControl.WndProc。 由于到了TControl.WndProc仍然没有处理WM_COMMAND消息，因此TControl便调用TObject的消息分派服务虚拟方法Dispatch来处理此消息：  procedure TControl.WndProc(var Message: TMessage); var   Form: TCustomForm;   KeyState: TKeyboardState;    WheelMsg: TCMMouseWheel; begin …  Dispatch(Message); end; TObject.Dispatch会在TForm1的动态方法窗体中搜寻是否有方法可以处理WM_COMMAND消息，由于TForm1没有定义处理WM_COMMAND消息的动态方法，因此TObject.Dispatch会继续到TForm1的父类的动态方法表格中搜寻，一直到寻找到能够处理WM_COMMAND窗口消息的动态方法为止。 TCustomForm = class(TScrollingWinControl)   private    procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;   … end;   procedure TCustomForm.WMCommand(var Message: TWMCommand); begin   with Message do     if (Ctl <> 0) or (Menu = nil) or not Menu.DispatchCommand(ItemID) then       inherited; end; TCustomForm.WMCommand最终会调用到TWinControl的WMCommand来处理WM_COMMAND窗口消息： TWinControl = class(TControl)   private procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;  … end; 而TWinControl.WMCommand就是解开VCL Framework处理窗口消息并且连接到程序员在Delphi程序单元中撰写的处理函数的秘密的地方。TWinControl.WMCommand的实现程序代码首先调用DoControlMsg函数来处理触发的窗口消息，并且传入触发事件的窗口控件Handle值以及窗口消息。当然如果DoControlMsg无法处理此窗口消息，那么TWinControl.WMCommand便再调用TWinControl的父类来处理。 procedure TWinControl.WMCommand(var Message: TWMCommand); begin   if not DoControlMsg(Message.Ctl, Message) then inherited; end; DoControlMsg的函数的工作是什么？DoControlMsg接受的参数是窗口控件Handle值，因此DoControlMsg必须先经由此Handle值找到对应的VCL组件，然后再调用找到的VCL组件的处理函数来处理此窗口消息。 function DoControlMsg(ControlHandle: HWnd; var Message): Boolean; var   Control: TWinControl; begin   DoControlMsg := False;   Control := FindControl(ControlHandle);// 由此Handle值找到对应的VCL组件   if Control <> nil then     with TMessage(Message) do     begin       Result := Control.Perform(Msg + CN_BASE, WParam, LParam);       DoControlMsg := True;     end; end; DoControlMsg先调用FindControl函数，经由窗口控件的Handle值来找到封装的VCL组件。如果找到之后就调用找到的VCL组件的Perform方法，并且把窗口消息加上CN_Base转换成VCL　Framework的自定义消息。这是为了能够在VCL组件的VMT中的动态方法表格中找到处理此消息的动态方法。例如在这个范例中触发的消息是WM_COMMAND，但是在VCL Framework中VCL组件处理的此消息的对应自定义消息却是CN_COMMAND（详情见：CN_COMMAND           = CN_BASE + WM_COMMAND;Perform(Msg+CN_BASE)）： procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;   function FindControl(Handle: HWnd): TWinControl; var   OwningProcess: DWORD; begin   Result := nil;   if (Handle <> 0) and (GetWindowThreadProcessID(Handle, OwningProcess) <> 0) and      (OwningProcess = GetCurrentProcessId) then   begin     if GlobalFindAtom(PChar(ControlAtomString)) = ControlAtom then       Result := Pointer(GetProp(Handle, MakeIntAtom(ControlAtom)))     else       Result := ObjectFromHWnd(Handle);   end; end;   function ObjectFromHWnd(Handle: HWnd): TWinControl; var   OwningProcess: DWORD; begin   if (GetWindowThreadProcessID(Handle, OwningProcess) <> 0) and      (OwningProcess = GetCurrentProcessID) then     Result := Pointer(SendMessage(Handle, RM_GetObjectInstance, 0, 0))   else     Result := nil; end; 在ObjectFromHWnd用来搜寻相对应的VCL组件的方法就是调用Window API的SendMessage向此窗口控件发出询问消息RM_GetObjectInstance，然后就可以经由VCL组件自己回传符合的VCL组件了。 为什么使用SendMessage发出RM_GetObjectInstance消息就可以自动找到相对应的封装的VCL控件？ 前面我们说明VCL Framework如何封装窗口时，已经说明了VCL组件使用虚拟方法WndProc来处理窗口消息，并且经由定义各种处理特定窗口消息的动态方法来处理特定窗口消息。不过对于VCL组件不处理的窗口消息，就会由VCL　Framework中的DefaultHandler函数以及窗口的内定窗口消息处理函数DefWindowProc来处理。而每一个VCL组件在DefaultHandler函数中便会处理ObjectFromHwnd函数中发出的RM_GetObjectInstance消息。 procedure TWinControl.DefaultHandler(var Message); begin   if FHandle <> 0 then   begin     with TMessage(Message) do     begin       if (Msg = WM_CONTEXTMENU) and (Parent <> nil) then       begin         Result := Parent.Perform(Msg, WParam, LParam);         if Result <> 0 then Exit;       end;       case Msg of         WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:           Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);         CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:           begin             SetTextColor(WParam, ColorToRGB(FFont.Color));             SetBkColor(WParam, ColorToRGB(FBrush.Color));             Result := FBrush.Handle;           end;       else         if Msg = RM_GetObjectInstance then           Result := Integer(Self)         else           Result := CallWindowProc(FDefWndProc, FHandle, Msg, WParam, LParam);       end;       if Msg = WM_SETTEXT then         SendDockNotification(Msg, WParam, LParam);     end;   end   else     inherited DefaultHandler(Message); end; 因此当ObjectFromHWnd调用SendMessage API之后，由于VCL组件没有处理RM_GetObjectInstance消息的动态方法，因此最后TObject的消息分派服务会把未处理的消息分派级DefaultHandler，而DefaultHandler在得到执行权并且检查触发的消息是RM_GetObjectInstance之后自然就加以处理并且回传VCL组件自己了。ObjectFromHwnd使用了非常聪明的方法来搜寻目标VCL组件，比使用一个For循环直接在Delphi应用程序中一一地搜寻所有的VCL组件巧妙得多，绝对值得我们学习并善加使用这个巧妙的设计和技巧。 DoControlMsg找到目标VCL组件后，就调用TControl的Perform方法把窗口消息分派至最终的VCL组件和它的消息处理函数。在TControl.perform中，Perform先创建一个TMessage数据结构内容，最后调用VCL组件重载的WindowProc函数来处理窗口消息: function TControl.Perform(Msg: Cardinal; WParam, LParam: Longint): Longint; var   Message: TMessage; begin   Message.Msg := Msg;   Message.WParam := WParam;   Message.LParam := LParam;   Message.Result := 0;   if Self <> nil then WindowProc(Message);   Result := Message.Result; end; 在TControl的构造函数中，已经把虚拟方法WndProc指定给了Perform函数中的WindowProc特性值了，所以Perform是调用VCL组件的虚拟方法WndProc来处理窗口消息。 constructor TControl.Create(AOwner: TComponent); begin   inherited Create(AOwner);   FWindowProc := WndProc;   … end; 而VCL组件的虚拟方法WndProc则会再经由TObject的Dispatch在VCL组件中搜寻能够处理此消息的处理函数，我们再到TButton类中果然就可以发现TButton定义了CNCommand方法来处理DoControlMsg发出的CN_COMMAND消息： TButton = class(TButtonControl)   private procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; … end; TButton的CNCommand先确定触发的消息是否点击消息，如果是的话就调用动态方法Click来处理TButton组件被点击的事件： procedure TButton.CNCommand(var Message: TWMCommand); begin   if Message.NotifyCode = BN_CLICKED then Click; end; Click方法是一个动态方法，它是定义在TControl类中，并且由TButton重载的： TButton = class(TButtonControl)   …  public   procedure Click; override; … end; TControl = class(TComponent) … protected procedure Click; dynamic; … end; Click方法使用动态方法声明当然也是为了减少VCL派生类VMT的大小，TButton的Click方法先把包含它的TForm组件的ModalResult特性值设定成ModalResult，接着调用父类TControl.click准备连接程序撰写的事件处理函数： procedure TButton.Click; var   Form: TCustomForm; begin   Form := GetParentForm(Self);   if Form <> nil then Form.ModalResult := ModalResult;   inherited Click; end; procedure TControl.Click; begin   { Call OnClick if assigned and not equal to associated action's OnExecute.     If associated action's OnExecute assigned then call it, otherwise, call    OnClick. }   if Assigned(FOnClick) and (Action <> nil) and (@FOnClick <> @Action.OnExecute) then     FOnClick(Self)   else if not (csDesigning in ComponentState) and (ActionLink <> nil) then     ActionLink.Execute(Self)   else if Assigned(FOnClick) then     FOnClick(Self); end;//关联到自定义的事件中。

 

43、动态消息和VCL事件处理函数的结合

procedure TControl.Click; begin   { Call OnClick if assigned and not equal to associated action's OnExecute.     If associated action's OnExecute assigned then call it, otherwise, call    OnClick. }   if Assigned(FOnClick) and (Action <> nil) and (@FOnClick <> @Action.OnExecute) then     FOnClick(Self)   else if not (csDesigning in ComponentState) and (ActionLink <> nil) then     ActionLink.Execute(Self)   else if Assigned(FOnClick) then     FOnClick(Self); end;