您的位置：首页 > 运维架构 > 网站架构

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

2009-03-10 15:40 453 查看
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;
内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理 点击这里给我发消息
标签： 
相关文章推荐
新的分享
章节导航