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); // 第一步,收到WM_PAINT消息 begin if (Message.DC <> 0) and not (csDestroying in ComponentState) then begin Canvas.Lock; try Canvas.Handle := Message.DC; try Paint; // 第二步,调用自己的Paint虚函数 finally Canvas.Handle := 0; end; finally Canvas.Unlock; end; end; end; procedure TGraphicControl.Paint; // 提前准备:提前由程序员覆盖(目前是空函数) begin end;
TControl处理所有鼠标消息 + 位置,字体,对齐,Enable等等 + 部分消息处理。感觉内容比较简单,精华不在这里。
TControl = class(TComponent) FParent: TWinControl; FWindowProc: TWndMethod; FControlStyle: TControlStyle; FControlState: TControlState; FParentFont: Boolean; FParentColor: Boolean; FLeft: Integer; FTop: Integer; FWidth: Integer; FHeight: Integer; FVisible: Boolean; FEnabled: Boolean; FIsControl: Boolean; FFont: TFont; FColor: TColor; FHint: string; FText: PChar; FOnClick: TNotifyEvent; FOnDblClick: TNotifyEvent; 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 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; procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED; procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED; procedure CMMouseActivate(var Message: TCMMouseActivate); message CM_MOUSEACTIVATE; procedure CMParentFontChanged(var Message: TCMParentFontChanged); message CM_PARENTFONTCHANGED; procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED; procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED; procedure CMParentShowHintChanged(var Message: TMessage); message CM_PARENTSHOWHINTCHANGED; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST; procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST; procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED; procedure CMParentBiDiModeChanged(var Message: TMessage); message CM_PARENTBIDIMODECHANGED; procedure CMMouseWheel(var Message: TCMMouseWheel); message CM_MOUSEWHEEL; procedure CMGesture(var Message: TCMGesture); message CM_GESTURE; procedure CMParentTabletOptionsChanged(var Message: TMessage); message CM_PARENTTABLETOPTIONSCHANGED; procedure Click; dynamic; procedure DblClick; dynamic; function GetClientRect: TRect; virtual; procedure Loaded; override; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure BringToFront; function GetParentComponent: TComponent; override; function HasParent: Boolean; override; procedure SetTextBuf(Buffer: PChar); function ClientToScreen(const Point: TPoint): TPoint; function ClientToParent(const Point: TPoint; AParent: TWinControl = nil): TPoint; procedure Hide; procedure Refresh; procedure Repaint; virtual; procedure Show; procedure Update; virtual; function DesignWndProc(var Message: TMessage): Boolean; dynamic; procedure WndProc(var Message: TMessage); virtual; // 处理了不少消息 procedure DefaultHandler(var Message); override; function Perform(Msg: Cardinal; WParam: WPARAM; LParam: PChar): LRESULT; overload; function Perform(Msg: Cardinal; WParam: WPARAM; var LParam: TRect): LRESULT; overload; property WindowProc: TWndMethod read FWindowProc write FWindowProc; property Parent: TWinControl read FParent write SetParent;
procedure TControl.Invalidate; begin InvalidateControl(Visible, csOpaque in ControlStyle); end; procedure TControl.InvalidateControl(IsVisible, IsOpaque: Boolean); begin if (IsVisible) and (Parent <> nil) and Parent.HandleAllocated then begin Rect := BoundsRect; InvalidateRect(Parent.Handle, Rect, not (IsOpaque or (csOpaque in Parent.ControlStyle) or BackgroundClipped)); // API 使得父控件的部分区域失效 end; end; // (非重载)显示自己 procedure TControl.Show; begin if Parent <> nil then Parent.ShowControl(Self); if not (csDesigning in ComponentState) or (csNoDesignVisible in ControlStyle) then Visible := True; end; // (重载)通知父控件刷新(注意,它的父类是一个TWinControl) // 貌似挺巧妙,因为重载,所以先调用了TWinControl.Update 后面就不是当前类管的事情了。 // 但是单独的TWinControl子控件重载了Update消息,所以不会用到它。 // 也许TGraphicControl 才会用到TControl.Update; ? procedure TControl.Update; begin if Parent <> nil then Parent.Update; end; // (非重载)表面上看多此一举,但它其实可以调用子类的Repaint(通用方法) procedure TControl.Refresh; begin Repaint; end; // (重载)计算剪裁区域以后,还是发给了父类去重绘。父类的PaintControls会给每一个子控件发WM_PAINT消息。 // 每个子控件都用Handle区分。而消息队列是线程为载体的,所以不矛盾 // 所以调用TControl.Repaint;来刷新也没有问题。单独的TWinControl子控件重载了Repaint消息,所以不会用到它。 // 也许TGraphicControl 才会用到TControl.Repaint; ? procedure TControl.Repaint; var DC: HDC; begin if (Visible) and (Parent <> nil) and // 当前控件可显示 Parent.HandleAllocated then if csOpaque in ControlStyle then // 当前控件不透明(即需要显示) begin DC := GetDC(Parent.Handle); // 取得父类的句柄(注意,它的父类是一个TWinControl) try IntersectClipRect(DC, Left, Top, Left + Width, Top + Height); // API 给父类的句柄创建剪裁区 Parent.PaintControls(DC, Self); // 父类再去画剩余部分,相当于调用 TWinControl.PaintControls(DC: HDC; First: TControl); finally ReleaseDC(Parent.Handle, DC); end; end else // 如果当前控件透明,就是失效后立刻刷新显示(即当前控件的图形没有变化,只是需要重新刷新显示的问题) begin Invalidate; // 存在要求显示(透明的情况下) Update; end; end;
对比一下TWinControl.Repaint函数,思考为什么不透明的时候,会多了一段详细的自绘代码?
procedure TWinControl.Repaint; begin Invalidate; Update; end;
说白了就是重新裁剪,而且是对父控件的DC进行重新剪裁。我估计,这里的代码怕的是,图形控件既显示(visible),又不透明(csOpaque)的情况下,图形本身的大小随时可能会变,所以每次都需要重新剪裁。而不透明的情况下,不存在这个问题,所以直接刷新就行了。
但是新问题又来了,剪裁以后,居然没有要求使无效和刷新,为什么呢?通过查询TWinControl.PaintControls的代码得知:
procedure TWinControl.PaintControls(DC: HDC; First: TControl); var I, Count, SaveIndex: Integer; FrameBrush: HBRUSH; begin if DockSite and UseDockManager and (DockManager <> nil) then DockManager.PaintSite(DC); if FControls <> nil then begin I := 0; if First <> nil then begin I := FControls.IndexOf(First); if I < 0 then I := 0; end; Count := FControls.Count; while I < Count do begin with TControl(FControls[I]) do if (Visible or (csDesigning in ComponentState) and not (csNoDesignVisible in ControlStyle)) and RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then begin if csPaintCopy in Self.ControlState then Include(FControlState, csPaintCopy); SaveIndex := SaveDC(DC); MoveWindowOrg(DC, Left, Top); IntersectClipRect(DC, 0, 0, Width, Height); Perform(WM_PAINT, DC, 0); RestoreDC(DC, SaveIndex); Exclude(FControlState, csPaintCopy); end; Inc(I); end; end; if FWinControls <> nil then for I := 0 to FWinControls.Count - 1 do with TWinControl(FWinControls[I]) do if FCtl3D and (csFramed in ControlStyle) and (Visible or (csDesigning in ComponentState) and not (csNoDesignVisible in ControlStyle)) then begin FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow)); FrameRect(DC, Rect(Left - 1, Top - 1, Left + Width, Top + Height), FrameBrush); DeleteObject(FrameBrush); FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight)); FrameRect(DC, Rect(Left, Top, Left + Width + 1, Top + Height + 1), FrameBrush); DeleteObject(FrameBrush); end; end;
当场就要求所有图形子控件执行WM_PAINT,即模拟图形控件收到WM_PAINT,即立刻要求全部重绘,所以也就不必使无效和刷新了。
做个实验测试一下,看是不是图形控件剪裁区域变化以后的问题(确实当场起作用了):
procedure TForm1.Button2Click(Sender: TObject); begin image1.Width :=100; end; property Width: Integer read FWidth write SetWidth; procedure TControl.SetWidth(Value: Integer); begin SetBounds(FLeft, FTop, Value, FHeight); Include(FScalingFlags, sfWidth); end; procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin if CheckNewSize(AWidth, AHeight) and ((ALeft <> FLeft) or (ATop <> FTop) or (AWidth <> FWidth) or (AHeight <> FHeight)) then begin InvalidateControl(Visible, False); // TControl的函数,注意这里的osPraque是false,即当前控件处于透明状态。 FLeft := ALeft; FTop := ATop; FWidth := AWidth; FHeight := AHeight; UpdateAnchorRules; Invalidate; // TControl的函数,为什么要失效两遍?因为长宽高可能变化了。 Perform(WM_WINDOWPOSCHANGED, 0, 0); RequestAlign; if not (csLoading in ComponentState) then Resize; end; end; procedure TControl.WMWindowPosChanged(var Message: TWMWindowPosChanged); begin inherited; { Update min/max width/height to actual extents control will allow } if ComponentState * [csReading, csLoading] = [] then begin with Constraints do begin if (MaxWidth > 0) and (Width > MaxWidth) then FMaxWidth := Width else if (MinWidth > 0) and (Width < MinWidth) then FMinWidth := Width; if (MaxHeight > 0) and (Height > MaxHeight) then FMaxHeight := Height else if (MinHeight > 0) and (Height < MinHeight) then FMinHeight := Height; end; if Message.WindowPos <> nil then with Message.WindowPos^ do if (FHostDockSite <> nil) and not (csDocking in ControlState) and (Flags and SWP_NOSIZE = 0) and (cx <> 0) and (cy <> 0) then CalcDockSizes; end; end;
问题:我不明白,Form1是什么收到的WM_PAINT消息,使得Image1被重绘的?
回答:系统空闲时候探测无效区域,发现有,就立刻发送WM_PAINT消息。
Invalidate 发起消息, 在下一个消息循环就会知道要 paint
Invalidate之后,系统会选择一个时间发送WM_PAINT消息。
系统会在需要重绘的时候计算需要重绘的Region,然后发送WM_PAINT给相应窗口
我刚才没想起来 一头钻到updateWindow这种直接调用的思维里去了
-------------------------------------------------------------
最后:Reflesh是通用方法,但其实扰乱思路,不用管