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

19、Framework常用方法

1. Place Holder方法 所谓Place Holder方法是指父类的一些虚拟方法被实现为空白的函数而不声明为抽象方法。 2.逐渐增加法 所谓逐渐增加法是指父类提供了基础的实现，再交由派生类提供更多的实现。 1. 三明治手法 所谓三明治手法是指派生类在改写父类的方法是，会在使用关键字inherited调用父类的实现之前先加入一些派生类的程序代码，再调用父类的实现方法，最后则再加入派生类的实现。 2. 覆写父类实现法 决定完全覆盖父类的实现而不是改写父类的实现，这种手法称为覆写父类实现法。 3. BootStrap设计法 所谓BootStrap设计法是指父类会定义各种服务方法，但是这些服务都需要特定的标地，父类在实现服务方法时都会使用特定的标地，但是这个特定的标志却是只由派生类来提供，并不由父类提供。这种让特定的标地延迟到派生类才提供的设计便称为BootStrap设法法。

20、TComponent类

TComponent = class(TPersistent) private FName: TComponentName; FTag: Longint; public constructor Create(AOwner:TComponent);virtual; destructor Destroy;override; published property Name: TComponentName read FName write SetName stored False; property Tag: Longint read FTag write FTag default 0; end; constructor TComponent.Create(AOwner: TComponent); begin FComponentStyle := [csInheritable]; if AOwner <> nil then AOwner.InsertComponent(Self); end; destructor TComponent.Destroy; begin Destroying; if FFreeNotifies <> nil then begin while Assigned(FFreeNotifies) and (FFreeNotifies.Count > 0) do TComponent(FFreeNotifies[FFreeNotifies.Count - 1]).Notification(Self, opRemove); FreeAndNil(FFreeNotifies); end; DestroyComponents; if FOwner <> nil then FOwner.RemoveComponent(Self); inherited Destroy; end; TComponent = class(TPersistent) private FOwner: TComponent; FName: TComponentName; FTag: Longint; FComponents: TList; FFreeNotifies: TList; public constructor Create(AOwner:TComponent);virtual; destructor Destroy;override; procedure InsertComponent(AComponent: TComponent); procedure RemoveComponent(AComponent: TComponent); property Components[Index: Integer]: TComponent read GetComponent; property ComponentCount: Integer read GetComponentCount; property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex; property ComponentState: TComponentState read FComponentState; property ComponentStyle: TComponentStyle read FComponentStyle; property DesignInfo: Longint read FDesignInfo write FDesignInfo; property Owner: TComponent read FOwner; published property Name: TComponentName read FName write SetName stored False; property Tag: Longint read FTag write FTag default 0; end; procedure TComponent.InsertComponent(AComponent: TComponent); begin AComponent.ValidateContainer(Self); ValidateRename(AComponent, '', AComponent.FName); Insert(AComponent); AComponent.SetReference(True); if csDesigning in ComponentState then AComponent.SetDesigning(True); Notification(AComponent, opInsert); end; procedure TComponent.Insert(AComponent: TComponent); begin if FComponents = nil then FComponents := TList.Create; FComponents.Add(AComponent); AComponent.FOwner := Self; end; procedure TComponent.Notification(AComponent: TComponent; Operation: TOperation); var I: Integer; begin if (Operation = opRemove) and (AComponent <> nil) then RemoveFreeNotification(AComponent); if FComponents <> nil then begin I := FComponents.Count - 1; while I >= 0 do begin TComponent(FComponents[I]).Notification(AComponent, Operation); Dec(I); if I >= FComponents.Count then I := FComponents.Count - 1; end; end; end; TComponentState = set of (csLoading, csReading, csWriting, csDestroying, csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification, csInline, csDesignInstance); TComponentStyle = set of (csInheritable, csCheckPropAvail, csSubComponent, csTransient);

21、TControl类思想

TControl=class(TComponent) //鼠标服务 //光标服务 //事件服务 end; TWinControl=class(TControl) end; TVCLControl=class(TControl) end; TListBox=class(TWinControl) end;

22、TControl类

TControl = class(TComponent) private FParent: TWinControl; FWindowProc: TWndMethod; FLeft: Integer; FTop: Integer; FWidth: Integer; FHeight: Integer; FControlStyle: TControlStyle; FControlState: TControlState; … published property Left: Integer read FLeft write SetLeft; property Top: Integer read FTop write SetTop; property Width: Integer read FWidth write SetWidth; property Height: Integer read FHeight write SetHeight; property Cursor: TCursor read FCursor write SetCursor default crDefault; … end; FParent代表了TControl和TWinControl有紧密的耦合（Tight Coupling），而TWinControl是TControl的派生类，因此照理说FParent也可是TControl，因此FParent应该可以声明成TControl类型而不需要声明成TWinControl,检查TControl的实现程序代码可发现声明FParent为TWinControl纯粹是为了方便起见，然而这样的设计却造成了一些副作用，是值得重新考虑的。 控件需要使用光标、文字、颜色和字体以及其他的资源： FParentFont: Boolean; FParentColor: Boolean; FAlign: TAlign; FAutoSize: Boolean; FDragMode: TDragMode; FIsControl: Boolean; FBiDiMode: TBiDiMode; FParentBiDiMode: Boolean; FAnchors: TAnchors; 除了资源属性外，当外界改变控件使用的资源时，TControl类也必须定义响应资源事件的方法。CM_XXXChanged方法： procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED; procedure TControl.CMFontChanged(var Message: TMessage); begin Invalidate; end; procedure TControl.CMColorChanged(var Message: TMessage); begin Invalidate; end; procedure TControl.Invalidate; begin InvalidateControl(Visible, csOpaque in ControlStyle); end; procedure TControl.InvalidateControl(IsVisible, IsOpaque: Boolean); var Rect: TRect; function BackgroundClipped: Boolean; var R: TRect; List: TList; I: Integer; C: TControl; begin Result := True; List := FParent.FControls; I := List.IndexOf(Self); while I > 0 do begin Dec(I); C := List[I]; with C do if C.Visible and (csOpaque in ControlStyle) then begin IntersectRect(R, Rect, BoundsRect); if EqualRect(R, Rect) then Exit; end; end; Result := False; end; begin if (IsVisible or (csDesigning in ComponentState) and not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and Parent.HandleAllocated then begin Rect := BoundsRect; InvalidateRect(Parent.Handle, @Rect, not (IsOpaque or (csOpaque in Parent.ControlStyle) or BackgroundClipped)); end; end; 处理鼠标事件：WMXXButtonXXXX等方法： procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; 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 WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; 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 WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL; procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE; procedure TControl.WMLButtonDown(var Message: TWMLButtonDown); begin SendCancelMode(Self); inherited; if csCaptureMouse in ControlStyle then MouseCapture := True; if csClickEvents in ControlStyle then Include(FControlState, csClicked); DoMouseDown(Message, mbLeft, []); end; procedure TControl.WMNCLButtonDown(var Message: TWMNCLButtonDown); begin SendCancelMode(Self); inherited; end; procedure TControl.WMLButtonDown(var Message: TWMLButtonDown); begin SendCancelMode(Self); inherited; if csCaptureMouse in ControlStyle then MouseCapture := True; if csClickEvents in ControlStyle then Include(FControlState, csClicked); DoMouseDown(Message, mbLeft, []); end; procedure TControl.DoMouseDown(var Message: TWMMouse; Button: TMouseButton; Shift: TShiftState); begin if not (csNoStdEvents in ControlStyle) then with Message do if (Width > 32768) or (Height > 32768) then with CalcCursorPos do MouseDown(Button, KeysToShiftState(Keys) + Shift, X, Y) else MouseDown(Button, KeysToShiftState(Keys) + Shift, Message.XPos, Message.YPos); end; procedure TControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y); end;//和事件关联起来了。 VCL　Framework从TControl类开始就和Delphi的开发环境绑定在一起了。

23、TControl类2

处理消息和事件的服务 控件要处理事件和消息，因此TControl也要加入响应外界事件的处理机制，这就是TControl类中的虚拟方法WndProc和改写的DefaultHandler方法。 控件重绘服务 控件重绘是控件类最需要的核心服务，因为控件可以移动，可以改变使用的字体、颜色或是大小等，当这些事件发生时，控件都要进行重绘的工作。虚拟方法避免让TControl类和特定的平台绑定太紧密。 三个虚拟方法提供控件重绘的功能：Repaint、Invalidate以及Update。 procedure Repaint; virtual; procedure Update; virtual; procedure Invalidate; virtual; procedure TControl.Repaint; var DC: HDC; begin if (Visible or (csDesigning in ComponentState) and not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and Parent.HandleAllocated then if csOpaque in ControlStyle then begin DC := GetDC(Parent.Handle); try IntersectClipRect(DC, Left, Top, Left + Width, Top + Height); Parent.PaintControls(DC, Self); finally ReleaseDC(Parent.Handle, DC); end; end else begin Invalidate; Update; end; end; procedure TControl.Update; begin if Parent <> nil then Parent.Update; end; 同样，父类调用了子类的方法。

24、TWinControl类

TWinControl是TControl的派生类并且代表Windows控件，因此TWinControl自然加入了封装Windows控件的Handle、处理窗口事件的方法、经由Windows API进行控件图形用户界面控制的工作以及分派窗口消息的机制。 TWinControl = class(TControl) private FObjectInstance: Pointer; FDefWndProc: Pointer; FControls: TList; FWinControls: TList; FTabList: TList; FBrush: TBrush; FHandle: HWnd; FParentWindow: HWnd; … end; 创建和消灭Windows控件相关的方法： procedure CreateHandle; virtual; procedure CreateParams(var Params: TCreateParams); virtual; procedure CreateSubClass(var Params: TCreateParams; ControlClassName: PChar); procedure CreateWindowHandle(const Params: TCreateParams); virtual; procedure CreateWnd; virtual; procedure DestroyHandle; procedure DestroyWindowHandle; virtual; procedure DestroyWnd; virtual; 封装Windows消息： procedure WMPaint(var Message: TWMPaint); message WM_PAINT; procedure WMCommand(var Message: TWMCommand); message WM_COMMAND; procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; procedure WMSysColorChange(var Message: TWMSysColorChange); message WM_SYSCOLORCHANGE; procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL; procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL; 重绘： procedure WMPaint(var Message: TWMPaint); message WM_PAINT; procedure PaintControls(DC: HDC; First: TControl); procedure PaintHandler(var Message: TWMPaint); procedure PaintWindow(DC: HDC); virtual; procedure TWinControl.WMPaint(var Message: TWMPaint); var DC, MemDC: HDC; MemBitmap, OldBitmap: HBITMAP; PS: TPaintStruct; begin if not FDoubleBuffered or (Message.DC <> 0) then begin if not (csCustomPaint in ControlState) and (ControlCount = 0) then inherited else PaintHandler(Message); end else begin DC := GetDC(0); MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom); ReleaseDC(0, DC); MemDC := CreateCompatibleDC(0); OldBitmap := SelectObject(MemDC, MemBitmap); try DC := BeginPaint(Handle, PS); Perform(WM_ERASEBKGND, MemDC, MemDC); Message.DC := MemDC; WMPaint(Message); Message.DC := 0; BitBlt(DC, 0, 0, ClientRect.Right, ClientRect.Bottom, MemDC, 0, 0, SRCCOPY); EndPaint(Handle, PS); finally SelectObject(MemDC, OldBitmap); DeleteDC(MemDC); DeleteObject(MemBitmap); end; end; end;

25、TGraphicControl类

TGraphicControl = class(TControl) private FCanvas: TCanvas; procedure WMPaint(var Message: TWMPaint); message WM_PAINT; protected procedure Paint; virtual; property Canvas: TCanvas read FCanvas; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; constructor TGraphicControl.Create(AOwner: TComponent); begin inherited Create(AOwner); FCanvas := TControlCanvas.Create; TControlCanvas(FCanvas).Control := Self; end; destructor TGraphicControl.Destroy; begin if CaptureControl = Self then SetCaptureControl(nil); FCanvas.Free; inherited Destroy; end; procedure TGraphicControl.WMPaint(var Message: TWMPaint); begin if Message.DC <> 0 then begin Canvas.Lock; try Canvas.Handle := Message.DC; try Paint; finally Canvas.Handle := 0; end; finally Canvas.Unlock; end; end; end; procedure TGraphicControl.Paint; begin end; TBevel = class(TGraphicControl) private FStyle: TBevelStyle; FShape: TBevelShape; procedure SetStyle(Value: TBevelStyle); procedure SetShape(Value: TBevelShape); protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; published property Align; property Anchors; property Constraints; property ParentShowHint; property Shape: TBevelShape read FShape write SetShape default bsBox; property ShowHint; property Style: TBevelStyle read FStyle write SetStyle default bsLowered; property Visible; end; procedure TBevel.Paint; const XorColor = $00FFD8CE; var Color1, Color2: TColor; Temp: TColor; procedure BevelRect(const R: TRect); begin with Canvas do begin Pen.Color := Color1; PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top), Point(R.Right, R.Top)]); Pen.Color := Color2; PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom), Point(R.Left, R.Bottom)]); end; end; procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer); begin with Canvas do begin Pen.Color := C; MoveTo(X1, Y1); LineTo(X2, Y2); end; end; begin with Canvas do begin if (csDesigning in ComponentState) then begin if (FShape = bsSpacer) then begin Pen.Style := psDot; Pen.Mode := pmXor; Pen.Color := XorColor; Brush.Style := bsClear; Rectangle(0, 0, ClientWidth, ClientHeight); Exit; end else begin Pen.Style := psSolid; Pen.Mode := pmCopy; Pen.Color := clBlack; Brush.Style := bsSolid; end; end; Pen.Width := 1; if FStyle = bsLowered then begin Color1 := clBtnShadow; Color2 := clBtnHighlight; end else begin Color1 := clBtnHighlight; Color2 := clBtnShadow; end; case FShape of bsBox: BevelRect(Rect(0, 0, Width - 1, Height - 1)); bsFrame: begin Temp := Color1; Color1 := Color2; BevelRect(Rect(1, 1, Width - 1, Height - 1)); Color2 := Temp; Color1 := Temp; BevelRect(Rect(0, 0, Width - 2, Height - 2)); end; bsTopLine: begin BevelLine(Color1, 0, 0, Width, 0); BevelLine(Color2, 0, 1, Width, 1); end; bsBottomLine: begin BevelLine(Color1, 0, Height - 2, Width, Height - 2); BevelLine(Color2, 0, Height - 1, Width, Height - 1); end; bsLeftLine: begin BevelLine(Color1, 0, 0, 0, Height); BevelLine(Color2, 1, 0, 1, Height); end; bsRightLine: begin BevelLine(Color1, Width - 2, 0, Width - 2, Height); BevelLine(Color2, Width - 1, 0, Width - 1, Height); end; end; end; end;