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

最新推荐文章于 2024-09-27 12:05:02 发布

娃娃鸭

最新推荐文章于 2024-09-27 12:05:02 发布

阅读量1.2k

点赞数

文章标签： reference linux class pascal function include

本文链接：https://blog.csdn.net/wavaya/article/details/3976627

版权

35、TApplication创建的主窗体

Application.CreateForm(TForm1, Form1);

procedure TApplication.CreateForm(InstanceClass: TComponentClass; var Reference);

var

Instance: TComponent;

begin

Instance := TComponent(InstanceClass.NewInstance);

TComponent(Reference) := Instance;

try

Instance.Create(Self);

except

TComponent(Reference) := nil;

raise;

end;

if (FMainForm = nil) and (Instance is TForm) then

begin

TForm(Instance).HandleNeeded;

FMainForm := TForm(Instance);

end;

constructor TWinControl.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

{$IFDEF LINUX}

FObjectInstance := WinUtils.MakeObjectInstance(MainWndProc);

{$ENDIF}

{$IFDEF MSWINDOWS}

FObjectInstance := Classes.MakeObjectInstance(MainWndProc);

//设置回调函数

{$ENDIF}

FBrush := TBrush.Create;

FBrush.Color := FColor;

FParentCtl3D := True;

FTabOrder := -1;

FImeMode := imDontCare;

if SysLocale.PriLangID = LANG_JAPANESE then

FImeName := ''

else

FImeName := Screen.DefaultIme;

FUseDockManager := False;

FBevelEdges := [beLeft, beTop, beRight, beBottom];

FBevelInner := bvRaised;

FBevelOuter := bvLowered;

FBevelWidth := 1;

FHelpType := htContext;

end;

constructor TControl.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FWindowProc := WndProc;

…

end;

TControl = class(TComponent)

private

FParent: TWinControl;

FWindowProc: TWndMethod;

…

end;

procedure TWinControl.MainWndProc(var Message: TMessage);

begin

try

WindowProc(Message);

finally

FreeDeviceContexts;

FreeMemoryContexts;

end;

except

Application.HandleException(Self);

end;

申明：

procedure MainWndProc(var Message: TMessage);

不希望程序员覆盖，但是可以覆盖WindowProc方法。

TWinCtrol=class(TControl)

…

procedure WndProc(var Message: TMessage); override;

…

end;

TForm(Instance).HandleNeeded;

其实调用的是TWinControl.HandleNeeded;

procedure TWinControl.HandleNeeded;

begin

if FHandle = 0 then

begin

if Parent <> nil then Parent.HandleNeeded;

CreateHandle;

end;

procedure TWinControl.CreateHandle;

var

I: Integer;

begin

if FHandle = 0 then

begin

CreateWnd;

SetProp(FHandle, MakeIntAtom(ControlAtom), THandle(Self));

SetProp(FHandle, MakeIntAtom(WindowAtom), THandle(Self));

if Parent <> nil then

SetWindowPos(FHandle, Parent.PrecedingWindow(Self), 0, 0, 0, 0,

SWP_NOMOVE + SWP_NOSIZE + SWP_NOACTIVATE);

for I := 0 to ControlCount - 1 do

Controls[I].UpdateAnchorRules;

end;

procedure TCustomForm.CreateWnd;

var

ClientCreateStruct: TClientCreateStruct;

begin

inherited CreateWnd;

if NewStyleControls then

if BorderStyle <> bsDialog then

SendMessage(Handle, WM_SETICON, 1, GetIconHandle) else

SendMessage(Handle, WM_SETICON, 1, 0);

if not (csDesigning in ComponentState) then

case FormStyle of

fsMDIForm:

begin

with ClientCreateStruct do

begin

idFirstChild := $FF00;

hWindowMenu := 0;

if FWindowMenu <> nil then hWindowMenu := FWindowMenu.Handle;

end;

FClientHandle := Windows.CreateWindowEx(WS_EX_CLIENTEDGE, 'MDICLIENT',

nil, WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or

WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL or WS_CLIPSIBLINGS or

MDIS_ALLCHILDSTYLES, 0, 0, ClientWidth, ClientHeight, Handle, 0,

HInstance, @ClientCreateStruct);

{$IFDEF LINUX}

FClientInstance := WinUtils.MakeObjectInstance(ClientWndProc);

{$ENDIF}

{$IFDEF MSWINDOWS}

FClientInstance := Classes.MakeObjectInstance(ClientWndProc);//设置回调函数

{$ENDIF}

FDefClientProc := Pointer(GetWindowLong(FClientHandle, GWL_WNDPROC));

SetWindowLong(FClientHandle, GWL_WNDPROC, Longint(FClientInstance));

end;

fsStayOnTop:

SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or

SWP_NOSIZE or SWP_NOACTIVATE);

end;

TWincontrol=class(TControl)

…

procedure CreateWnd; virtual;

…

end;

procedure TWinControl.CreateWnd;

var

Params: TCreateParams;

TempClass: TWndClass;

ClassRegistered: Boolean;

begin

CreateParams(Params);//设定窗口注册属性，虚拟方法

with Params do

begin

if (WndParent = 0) and (Style and WS_CHILD <> 0) then

if (Owner <> nil) and (csReading in Owner.ComponentState) and

(Owner is TWinControl) then

WndParent := TWinControl(Owner).Handle

else

raise EInvalidOperation.CreateFmt(SParentRequired, [Name]);

FDefWndProc := WindowClass.lpfnWndProc;

ClassRegistered := GetClassInfo(WindowClass.hInstance, WinClassName, TempClass);

if not ClassRegistered or (TempClass.lpfnWndProc <> @InitWndProc) then

begin

if ClassRegistered then Windows.UnregisterClass(WinClassName,

WindowClass.hInstance);

WindowClass.lpfnWndProc := @InitWndProc;

WindowClass.lpszClassName := WinClassName;

if Windows.RegisterClass(WindowClass) = 0 then RaiseLastOSError;

end;

CreationControl := Self;

CreateWindowHandle(Params);

if FHandle = 0 then

RaiseLastOSError;

if (GetWindowLong(FHandle, GWL_STYLE) and WS_CHILD <> 0) and

(GetWindowLong(FHandle, GWL_ID) = 0) then

SetWindowLong(FHandle, GWL_ID, FHandle);

end;

StrDispose(FText);

FText := nil;

UpdateBounds;

Perform(WM_SETFONT, FFont.Handle, 1);

if AutoSize then AdjustSize;

end;

procedure TWinControl.CreateWindowHandle(const Params: TCreateParams);

begin

with Params do

FHandle := CreateWindowEx(ExStyle, WinClassName, Caption, Style,

X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param);

end;

TWinControl = class(TControl)

…

procedure CreateParams(var Params: TCreateParams); virtual;

…

end;

36、InitWndProc函数

InitWndProc被设定为主窗体创建的窗口控件的回调函数，最终窗口消息处理函数却是VCL类方法，所以InitWndProc一定需要进行转换的工作，让窗口的回调函数能够正确到达主窗体的窗口消息处理函数MainWndProc。

function InitWndProc(HWindow: HWnd; Message, WParam,

LParam: Longint): Longint;

{$IFDEF LINUX}

type

TThunkProc = function (HWindow: HWnd; Message, WParam, LParam: Longint): Longint stdcall;

var

WinControl: TWinControl;

{$ENDIF}

begin

CreationControl.FHandle := HWindow;

SetWindowLong(HWindow, GWL_WNDPROC,

Longint(CreationControl.FObjectInstance));//改变主窗体的回调函数

if (GetWindowLong(HWindow, GWL_STYLE) and WS_CHILD <> 0) and

(GetWindowLong(HWindow, GWL_ID) = 0) then

SetWindowLong(HWindow, GWL_ID, HWindow);

SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl));

SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl));

{$IFDEF LINUX}

WinControl := CreationControl;

CreationControl := nil;

Result := TThunkProc(WinControl.FObjectInstance)(HWindow, Message, WParam, LParam);

{$ENDIF}

asm

PUSH LParam

PUSH WParam

PUSH Message

PUSH HWindow //开始窗口的Pascal调用惯例转换成调用类方法的stdcall调用惯例

MOV EAX,CreationControl

MOV CreationControl,0

CALL [EAX].TWinControl.FObjectInstance //调用

MOV Result,EAX

end;

end;

37、CreateWindowHandle方法

procedure TCustomForm.CreateWindowHandle(const Params: TCreateParams);

var

CreateStruct: TMDICreateStruct;

NewParams: TCreateParams;

begin

if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then

begin

if (Application.MainForm = nil) or

(Application.MainForm.ClientHandle = 0) then

raise EInvalidOperation.Create(SNoMDIForm);

with CreateStruct do

begin

szClass := Params.WinClassName;

szTitle := Params.Caption;

hOwner := HInstance;

X := Params.X;

Y := Params.Y;

cX := Params.Width;

cY := Params.Height;

style := Params.Style;

lParam := Longint(Params.Param);

end;

WindowHandle := SendMessage(Application.MainForm.ClientHandle,

WM_MDICREATE, 0, Longint(@CreateStruct));

Include(FFormState, fsCreatedMDIChild);

end else

begin

NewParams := Params;

NewParams.ExStyle := NewParams.ExStyle and not WS_EX_LAYERED;

inherited CreateWindowHandle(NewParams);

Exclude(FFormState, fsCreatedMDIChild);

end;

SetLayeredAttribs;

end;

procedure TWinControl.CreateWindowHandle(const Params: TCreateParams);

begin

with Params do

FHandle := CreateWindowEx(ExStyle, WinClassName, Caption, Style,

X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param);

end;

38、小结

方法名称	说明
InitWndProc	VCL Framework中转换窗体窗口回调函数的轴心程序。InitWndProc会重新设定窗体封装的窗口控件的回调函数为MakeObjectInstance封装的类方法。
MainWndProc	窗体对象的窗口消息处理函数，但是实际上会调用虚拟方法WndProc来处理窗口消息
WndProc	虚拟方法，真正处理窗口消息的处理函数
CreateParams	虚拟方法，设定窗口类属性信息
CreateWindowHandle	虚拟方法，调Windows　API　CreateWindowEx创建封装性的原生窗口控件。