Delphi高手突破(四) Delphi高級進階

本文轉載自查看原文 2016-10-11 10:45 7777 delphi 高手突破

別人造磚我砌房！

Delphi  高手突破
VCL——Visual Component Library，是 Delphi 的基石。Delphi 的優秀，很大程度上得
益於 VCL 的優秀。
VCL 是 Delphi 所提供的基本組件庫，也就是所謂的 Application Framework，它對
Windows API（應用程序接口）進行了全面封裝，為桌面開發（不限於桌面開發）提供了
整套的解決方案，使得程序員可以在不知曉 API 的情況下進行 Windows編程。
不過，作為專業的程序員，不知曉API 是不可能的。VCL還是一個 Framework（應用
程序框架），可以將 VCL作為一個平台，程序員在其基礎上構建應用程序，便可以忽略很
多系統 API 的細節，而使得開發速度更快。
VCL 的組件也不同於 ActiveX控件，VCL 組件通過源代碼級連接到可執行文件中，因
此其速度更快。而且，企業版的 Delphi 帶有全部 VCL 庫的源代碼，這樣程序員不單單可
以知道如何使用 VCL 組件，更可以了解其運行機制與構架。
了解 VCL 的構架，無論對於編寫自己的 Application，還是設計程序框架，或者創建自
己的組件/類融入 VCL 構架中，都是必需和大有裨益的。
這也符合某種規律：在學習的時候，求甚解；而在應用的時候，則尋找捷徑。Delphi
和 VCL 都能滿足這兩種需求，因為使用它   可以不隱藏任何想知道的細節；   可以忽略不想知道的細節。
在本章中，將帶游歷 VCL 庫的核心，剖析 VCL 的代碼。從此，VCL 對您來說不會再
是神秘而艱澀的，因為帶領讀者它們同樣是用代碼鑄造成的。
4.1  VCL  概貌
先看一下 VCL 類圖的主要分支，如圖 4.1 所示。
在圖中可以看到，TObject 是 VCL 的祖先類，這也是 Object Pascal 語言所規定的。但
實際上，TObject 以及 TObject 聲明所在的 system.pas整個單元，包括在“編譯器魔法”話
題中提到的_ClassCreate等函數，都是編譯器內置支持的。因此，無法修改、刪除 system.pas
中的任何東西，也無法將 system.pas 加入你的 project，否則會得到“Identifier redeclared
‘system’”的錯誤提示，因 project 中已經被編譯器自動包含了 system單元。
意思是，TObject 是 Object Pascal 語言/編譯器本身的一個性質！注意：TObject 是屬於編譯器的特性！
TObject 封裝了 Object Pascal 類/對象的最基本行為。
TPersistent 派生自 TObject，TPersistent 使得自身及其派生類對象具有自我保存、持久
存在的能力。
TComponent派生自 TPersistent，這條分支之下所有的類都可以被稱為“組件”。組件
的一般特性是：
（1）可出現在開發環境的“組件板”上。

·66·

VCL  庫

TObject
……  TRegistry  TPersistent
4
TStrings  TComponent
TStringList  TApplication  TControl
TGraphicControl TWinControl
TCustomControl

圖4.1  VCL 類圖主要分支（深色表示核心分支）
（2）能夠擁有和管理其他組件。
（3）能夠存取自身（這是因為 TComponent 派生自 TPersistent）。
TControl 派生自 TComponent，其分支之下所有的類，都是在運行時可見的組件。
TWinControl 派生自 TControl，這個分支封裝了 Windows 系統的屏幕對象，也就是一
個真正的 Windows窗口（擁有窗口句柄）。
TCustomControl 派生自 TwinControl。從 TCustomControl 開始，組件擁有了 Canvas（畫
布）屬性。
從 4.2 節開始，將會先后結合 VCL 中一些核心類的實現代碼來了解它們。
4.2  TObject 與消息分發
首先來看一下 TObject 這個“萬物之源”究竟長得何等模樣。它的聲明如下：

  TObject = class
   constructor Create;
   procedure Free;
    class function InitInstance(Instance: Pointer): TObject;
   procedure CleanupInstance;
    function ClassType: TClass;

·67·

Delphi  高手突破
    class function ClassName: ShortString;
    class function ClassNameIs(const Name: string): Boolean;
    class function ClassParent: TClass;
    class function ClassInfo: Pointer;
    class function InstanceSize: Longint;
    class function InheritsFrom(AClass: TClass): Boolean;
    class function MethodAddress(const Name: ShortString): Pointer;
    class function MethodName(Address: Pointer): ShortString;
    function FieldAddress(const Name: ShortString): Pointer;
    function GetInterface(const IID: TGUID; out Obj): Boolean;
    class function GetInterfaceEntry(const IID: TGUID):
PInterfaceEntry;
    class function GetInterfaceTable: PInterfaceTable;
    function SafeCallException(ExceptObject: TObject;
      ExceptAddr: Pointer): HResult; virtual;
    procedure AfterConstruction; virtual;
    procedure BeforeDestruction; virtual;
    procedure Dispatch(var Message); virtual;
    procedure DefaultHandler(var Message); virtual;
    class function NewInstance: TObject; virtual;
    procedure FreeInstance; virtual;
    destructor Destroy; virtual;
end;

從 TObject 的聲明中可以看到，TObject 包含了諸如實例初始化、實例析構、RTTI、消
息分發等相關實現的方法。現在就來研究一下TObject與消息分發，這也是VCL對Windows
消息封裝的模型基礎。
在 TObject 類中，有一個 Dispatch()方法和一個 DefaultHandler()方法，它們都是與消息
分發機制相關的。
Dispatch()負責將特定的消息分發給合適的消息處理函數。首先它會在對象本身類型
的類中尋找該消息的處理函數，如果找到，則調用它；如果沒有找到而該類覆蓋了 TObject
的 DefaultHandler()，則調用該類的 DefaultHandler()；如果兩者都不存在，則繼續在其基
類中尋找，直至尋找到 TObject 這一層，而 TObject 已經提供了默認的 DefaultHandler()
方法。
先來看一個示例程序，它演示了消息分發及處理的過程。該程序的代碼及可執行文件
可在配書光盤的 MsgDisp 目錄下找到。
首先自定義一個消息結構 TMyMsg，它是我們自定義的消息記錄類型。對於自定義的
消息類型，VCL 只規定它的首 4 字節必須是消息編號，其后的數據類型任意。同時，VCL
也提供了一個 TMessage類型用於傳遞消息。在此程序中，不使用 TMessage，而用 TMyMsg
代替：

·68·

VCL  庫
type
  TMyMsg = record // 自定義消息結構
    Msg : Cardinal; // 首4 字節必須是消息編號
    MsgText : ShortString; // 消息的文字描述
end;

TMyMsg 記錄類型的第 2 個域我們定義為 MsgText，由該域的字符串來給出對這個消 4
息的具體描述信息。當然，這些信息都是由消息分發者給出的。
然后，定義一個類，由它接受外界發送給它的消息。這個類可以說明這個演示程序的
核心問題。

  TMsgAccepter = class // 消息接收器類
private
   // 編號為2000的消息處理函數
    procedure AcceptMsg2000(var msg : TMyMsg); message 2000;
   // 編號為2002的消息處理函數
    procedure AcceptMsg2002(var msg : TMyMsg); message 2002;
public
    procedure DefaultHandler(var Message); override; //默認處理方法
end;

在 Object Pascal 中，指明類的某個方法為某一特定消息的處理函數，則在其后面添加
message 關鍵字與消息值，以此來通知編譯器。正如上面類定義中的
procedure AcceptMsg2000(var msg : TMyMsg); message 2000;
指明 AcceptMsg2000()方法用來處理值為 2000 的消息，該消息以及參數將通過 msg 參數傳
遞給處理函數。
TMsgAccepter類除提供了值為 2000 和2002 的兩個消息的處理函數外，還提供了一個
默認的消息處理方法 DefaultHandler()。該方法是在 TObject 中定義的虛方法，而在
TMsgAccepter類中覆蓋（override）了該方法，重新給出了新的實現。
TMyMsg 結構聲明與 TMsgAccepter類的聲明與實現都被定義在 MsgDispTest 單元中。
完整的單元代碼如下，請參看其中的 TMsgAccepter類的各方法的實現：

unit MsgDispTest;

interface

uses Dialogs, Messages;

type

·69·

Delphi  高手突破
  TMyMsg = record
    Msg : Cardinal;
    MsgText : ShortString;
end;

  TMsgAccepter = class // 消息接收器類
private
    procedure AcceptMsg2000(var msg : TMyMsg); message 2000;
    procedure AcceptMsg2002(var msg : TMyMsg); message 2002;
public
    procedure DefaultHandler(var Message); override; //默認處理函數
end;

implementation

{ TMsgAccepter }

procedure TMsgAccepter.AcceptMsg2000(var msg: TMyMsg);
begin
ShowMessage('嗨，我收到了編號為 2000 的消息，它的描述是：' + msg.MsgText);
end;

procedure TMsgAccepter.AcceptMsg2002(var msg: TMyMsg);
begin
ShowMessage('嗨，我收到了編號為2002的消息，它的描述是：' + msg.MsgText);
end;

procedure TMsgAccepter.DefaultHandler(var message);
begin
ShowMessage('嗨，這個消息我不認識，無法接收，它的描述是：' +
   TMyMsg(message).MsgText);
end;

end.

接着就是界面代碼，我們在 Application 的主 Form（Form1）上放入 3 個按鈕，程序界
面如圖 4.2 所示。
界面上的 3個按鈕的名字分別是：btnMsg2000、btnMsg2001、btnMsg2002。該 3 個按
鈕用來分發 3 個消息，將 3 個消息的值分別定義為 2000、2001 和2002。
在 Form的 OnCreate 事件中，創建一個 TMsgAccepter類的實例。然后，在 3個按鈕的
OnClick 事件中分別加上代碼，將 3個不同的消息分發給 TMsgAccepter類的實例對象，以

·70·

VCL  庫
觀察 TMsgAccepter 作出的反應。最后，在 Form的 OnDestroy 事件中，析構 TMsgAccepter
類的實例對象。
4

圖4.2  消息分發演示程序界面
完整的界面程序單元代碼如下：

unit Unit1;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics,
    Controls,Forms, Dialogs, StdCtrls, MsgDispTest;

type
  TForm1 = class(TForm)
   btnMsg2000: TButton;
   btnMsg2001: TButton;
   btnMsg2002: TButton;
   Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnMsg2000Click(Sender: TObject);
    procedure btnMsg2002Click(Sender: TObject);
    procedure btnMsg2001Click(Sender: TObject);
end;

var
Form1: TForm1;
  MsgAccept : TMsgAccepter; // 自定義的消息接收類

implementation

{$R *.dfm}

·71·

Delphi  高手突破

procedure TForm1.FormCreate(Sender: TObject);
begin
// 創建TMsgAccepter類的實例
  MsgAccept := TMsgAccepter.Create();
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
// 析構TMsgAccepter類的實例
MsgAccept.Free();
  MsgAccept := nil;
end;

procedure TForm1.btnMsg2000Click(Sender: TObject);
var
  Msg : TMyMsg;
begin
// 將值為2000的消息分發給MsgAccept對象，觀察其反應
  Msg.Msg := 2000;
  Msg.MsgText := 'Message 2000'; // 消息的文字描述
MsgAccept.Dispatch(Msg); // 分發消息
end;

procedure TForm1.btnMsg2002Click(Sender: TObject);
var
  Msg : TMyMsg;
begin
// 將值為2002的消息分發給MsgAccept對象，觀察其反應
  Msg.Msg := 2002;
  Msg.MsgText := 'Message 2002'; // 消息的文字描述
MsgAccept.Dispatch(Msg); // 分發消息
end;

procedure TForm1.btnMsg2001Click(Sender: TObject);
var
  Msg : TMyMsg;
begin
// 將值為2001的消息分發給MsgAccept對象，觀察其反應
  Msg.Msg := 2001;
  Msg.MsgText := 'Message 2001'; // 消息的文字描述
MsgAccept.Dispatch(Msg); // 分發消息

·72·

VCL  庫
end;

end.

在 TMsgAccepter類的代碼中可以看到，它只能處理編號為 2000和 2002 的消息，而沒
有編號為 2001 的消息的處理函數，但它覆蓋了 TObject 的 DefaultHandler()，於是就提供了
4
默認的消息處理函數。
運行程序，分別單擊 3 個按鈕，得到了 3 句不同的回答。對於消息 2000 和 2002，
TMsgAccepter 照單全收，正確識別出所接收到的消息。而只有在接收消息 2001 時，由於
沒有提供專門的消息處理函數，導致了對 DefaultHandler()的調用。幸運的是，在
DefaultHandler 中，還可以使用 message 參數給出的附加信息（TMyMsg 記錄類型中的
MsgText 域）。
4.3  TControl 與Windows 消息的封裝
TObject 提供了最基本的消息分發和處理的機制，而 VCL 真正對 Windows系統消息的
封裝則是在 TControl 中完成的。
TControl 將消息轉換成 VCL 的事件，以將系統消息融入 VCL 框架中。
消息分發機制在 4.2 節已經介紹過，那么系統消息是如何變成事件的呢？
現在，通過觀察 TControl 的一個代碼片段來解答這個問題。在此只以鼠標消息變成鼠
標事件的過程來解釋，其余的消息封裝基本類似。
先摘取 TControl 聲明中的一個片段：

  TControl = class(TComponent)
Private
   ……
   FOnMouseDown: TMouseEvent;
   ……
   procedure DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
     Shift: TShiftState);
   ……
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
   ……
    procedure WMLButtonDown(var Message: TWMLButtonDown); message
     WM_LBUTTONDOWN;
    procedure WMRButtonDown(var Message: TWMRButtonDown); message
     WM_RBUTTONDOWN;
    procedure WMMButtonDown(var Message: TWMMButtonDown); message

·73·

Delphi  高手突破
     WM_MBUTTONDOWN;
   ……
protected
   ……
    property OnMouseDown: TMouseEvent read FOnMouseDown write
     FOnMouseDown;
   ……
end;

這段代碼是 TControl 組件類的聲明。如果你從沒有接觸過類似的 VCL 組件代碼的代
碼，不明白那些 property、read、write 的意思，那么可以先跳轉到 5.1 節閱讀一下相關的基
礎知識，然后再回過頭來到此處繼續。
TControl 聲明了一個 OnMouseDown屬性，該屬性讀寫一個稱為 FOnMouseDown 的事
件指針。因此，FOnMouseDown 會指向 OnMouseDown 事件的用戶代碼。
TControl 聲明了 WMLButtonDown、WMRButtonDown、WMMButtonDown 3 個消息
處理函數，它們分別處理 WM_LBUTTONDOWN、WM_RBUTTONDOWN、WM
_MBUTTONDOWN 3 個 Windows 消息，對應於鼠標的左鍵按下、右鍵按下、中鍵按下 3
個硬件事件。
另外，還有一個 DoMouseDown()方法和一個 MouseDown()的 dynamic 方法，它們與消
息處理函數之間 2 是什么樣的關系呢？
現在，就來具體看一下這些函數的實現。
這里是 3 個消息的處理函數：

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.WMRButtonDown(var Message: TWMRButtonDown);
begin
inherited;
  DoMouseDown(Message, mbRight, []);
end;

·74·

VCL  庫
procedure TControl.WMMButtonDown(var Message: TWMMButtonDown);
begin
inherited;
  DoMouseDown(Message, mbMiddle, []);
end;

當 TObject.Dispatch()將 WM_LBUTTONDOWN 消息、WM_RBUTTONDOWN 消息或 4
WM_MBUTTONDOWN 消息分發給 TControl 的派生類的實例后，WMLButtonDown()、
WMRButtonDown()或 WMMButtonDown()被執行，然后它們都有類似這樣
DoMouseDown(Message, mbRight, []);
的代碼來調用 DoMouseDown()：

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;

在 DoMouseDown()中進行一些必要的處理工作后（特殊情況下重新獲取鼠標位置），
就會調用 MouseDown()：

procedure TControl.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
end;

·75·

Delphi 高手突破
在 MouseDown()中，才會通過 FOnMouseDown 事件指針真正去執行用戶定義的
OnMouseDown 事件的代碼。
由此，完成了 Windows系統消息到 VCL 事件的轉換過程。
因此，從 TControl 派生的類都可以擁有 OnMouseDown 事件，只不過該事件屬性在
TControl 中被定義成 protected，只有其派生類可見，並且在派生類中可以自由選擇是否公
布這個屬性。要公布該屬性只需要簡單地將其聲明為 published 即可。如：

TMyControl = class(TControl)
published
property OnMouseDown;
end;

這些函數過程的調用關系如圖 4.3 所示。
DispDispatchatch(WM(WM__LLBBUTUTTTONDONDOWN); OWN);
WMMouseDown()
DoMouseDown()
MouseDown()
程序員的 OnMouseDown 事件代碼

圖4.3 WM_LBUTTONDOWN消息到OnMouseDown 事件的轉換過程
在此，只是以 OnMouseDown 事件為例。其實，VCL 對 Windows 各個消息的封裝大同
小異，以此一例足以說明事件模型的原理。
另外，值得注意的是，在上例中的 MouseDown()函數是一個 dynamic 方法，因此可以
通過在 TControl 派生類中覆蓋 MouseDown()來處理自己所編寫組件的鼠標按下事件，然后
通過
inherited;
語句調用 TControl 的 MouseDown()來執行使用組件的程序員所編寫的 OnMouseDown的代
碼。具體內容會在第 5章中展開。
至此，讀者應該已經了解了 VCL 事件與 Windows 消息的對應關系，應該知道平時為
組件寫的事件代碼是如何被執行的。
如果讀者感到自己對此還不是很清楚，那么建議您將本節與 4.2 節再多讀幾遍，甚至
可以自己打開 Delphi 親自查看一下 VCL 的源代碼，相信很快就會明白的。

·76·

VCL  庫
4.4  TApplication與主消息循環
現在已經明白了 VCL 消息分發機制以及 VCL 的事件模型，但如果曾經使用純 API 編
寫過 Windows 程序，一定知道 Windows 應用程序的每一個窗口都有一個大的消息循環以
4
及一個窗口函數（WndProc）用以分發和處理消息。
VCL 作為一個 Framework，當然會將這些東西隱藏起來，而重新提供一種易用的、易
理解的虛擬機制給程序員。
那么 VCL 是如何做到的呢？
本節就來解答這個問題。
只要代碼單元中包含了 Forms.pas，就會得到一個對象——Application。利用它可以幫
助我們完成許多工作。例如要退出應用程序，可以使用
Application.Terminate();
Application對象是 VCL提供的，在 Forms.pas 中可以看到如下這個定義：

var
Application: TApplication;

從表現來看，TApplication 類定義了一個應用程序的特性及行為，可以從 Application
對象得到應用程序的可執行文件名稱（ExeName），設置應用程序的標題（Title）等屬性，
也可以執行最小化（Minimize）、打開幫助文件（HelpCommand）等操作。
當創建一個默認的應用程序時，會自動得到以下幾行代碼：

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

這幾行代碼很簡潔地展示了 TApplication 的功能、初始化、創建必要的窗體、運行……
但是，這幾行代碼具體做了什么幕后操作呢？Application.Run 之后，程序流程走向了
哪里？
4.4.1  脫離VCL 的Windows 程序
讀者有必要先了解一個標准 Windows程序的運行流程。如果現在還不了解，請看下面
的一個示例程序。在此，給出一個用純 Pascal 所編寫的十分簡單的 Windows應用程序，以

·77·

Delphi  高手突破
演示標准 Windows程序是如何被建立及運行的。該程序的代碼及可執行文件可在配書光盤
的 WindowDemo 目錄下找到，程序可被 Delphi編譯通過。
以下是代碼清單，請注意其中的注釋：

program WindowDemo;

uses Windows, Messages;

// 窗口函數，窗口接到消息時被Windows 所調用
function WindowProc(hwnd : HWND; uMsg : Cardinal; wParam : WPARAM;
  lParam : LPARAM) : LResult; stdcall;
begin
  Result := 0;

  case uMsg of
// 關閉窗口消息，當用戶關閉窗口后，通知主消息循環結束程序
  WM_CLOSE : PostMessage(hwnd, WM_QUIT, 0, 0);
// 鼠標左鍵按下消息
  WM_LBUTTONDOWN : MessageBox(hwnd, 'Hello!', '和您打個招呼',
   MB_ICONINFORMATION);

else
// 其他消息做默認處理
    Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
end;
end;

var
  wndcls : WNDCLASS; // 窗口類的記錄（結構）類型
  hWnd : THandle;
  Msg : tagMSG; // 消息類型
begin
  wndcls.style := CS_DBLCLKS; // 允許窗口接受鼠標雙擊
  wndcls.lpfnWndProc := @WindowProc; // 為窗口類指定窗口函數
  wndcls.cbClsExtra := 0;
  wndcls.cbWndExtra := 0;
  wndcls.hInstance := hInstance;
  wndcls.hIcon := 0;
  wndcls.hCursor := LoadCursor(hInstance, 'IDC_ARROW');
  wndcls.hbrBackground := COLOR_WINDOWFRAME;
  wndcls.lpszMenuName := nil;

·78·

VCL  庫
  wndcls.lpszClassName := 'WindowClassDemo'; // 窗口類名稱

// 注冊窗口類
  if RegisterClass(wndcls) = 0 then
   Exit;

// 創建窗口  4
  hWnd := CreateWindow(
    'WindowClassDemo',  // 窗口類名稱
   'WindowDemo',     // 窗口名稱
    WS_BORDER or WS_CAPTION or WS_SYSMENU, // 窗口類型
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   0,
   0,
   hInstance,
   nil
);
  if hWnd = 0 then
   Exit;

// 顯示窗口
ShowWindow(hWnd, SW_SHOWNORMAL);
UpdateWindow(hWnd);

// 創建主消息循環，處理消息隊列中的消息並分發
// 直至收到WM_QUIT消息，退出主消息循環，並結束程序
// WM_QUIT消息由PostMessage()函數發送
  while GetMessage(Msg, hWnd, 0, 0) do
begin
   TranslateMessage(Msg);
   DispatchMessage(Msg);
end;
end.

該程序沒有使用 VCL，它所做的事情就是顯示一個窗口。當在窗口上單擊鼠標右鍵時，
會彈出一個友好的對話框向您問好。如果從來不曾了解過這些，那么建議您實際運行一下
光盤上的這個程序，對其多一些感性認識。
就是這樣一個簡單的程序，演示了標准 Windows程序的流程：

·79·

Delphi  高手突破
（1）從入口函數 WinMain 開始。
（2）注冊窗口類及窗口函數（Window Procedure）。
（3）創建並顯示窗口。
（4）進入主消息循環，從消息隊列中獲取並分發消息。
（5）消息被分發后，由 Windows 操作系統調用窗口函數，由窗口函數對消息進行
處理。
在 Object Pascal 中看不到所謂的“WinMain”函數。不過，其實整個 program的 begin
處就是 Windows程序的入口。
注冊窗口類通過系統 API 函數 RegisterClass()來完成，它向 Windows 系統注冊一個窗
口的類型。
注冊窗口類型完成后，就可以創建這個類型的窗口實例。創建出一個真正的窗口可通
過 API 函數 CreateWindow()來實現。
創建出的窗口實例通過 API 函數 ShowWindow()來使得它顯示在屏幕上。
當這一切都完成后，窗口開始進入一個 while 循環以處理各種消息，直至 API 函數
GetMessage()返回 0 才退出程序。循環中，程序需要從主線程的消息隊列中取出各種消息，
並將它分發給系統，然后由 Windows 系統調用窗口的窗口函數（WndProc），以完成窗口
對消息的響應處理。
也許有人會覺得，寫一個 Windows 應用程序原來是那么繁瑣，需要調用大量的 API
函數來完成平時看起來很簡單的事情，而平時使用 VCL 編寫窗口應用程序時，似乎從來沒
有遇到過這些東西。是的，VCL 作為一個 Framework 為我們做了很多事情，其中的
TApplication除了定義一個應用程序的特性及行為外，另一個重要的使命就是封裝以上的那
些令人討厭的、繁瑣的步驟。
那它是如何做到的呢？
4.4.2  Application 對象的本質
在 Delphi 中，我們為每個項目（非 DLL 項目，以下討論皆是）所定義的 Main Form
並不是主線程的主窗口。每個 Application 的主線程的主窗口（也就是出現在系統任務欄中
的）是由 TApplication 創建的一個 0×0 大小的不可見的窗口，但它可以出現在任務欄上。
其余由程序員創建的 Form，都是該窗口的子窗口。
程序員所定義的 Main Form由 Application 對象來調度。Delphi所編寫的應用程序有時
會出現如圖 4.4 所示的情況：任務欄標題和程序主窗口標題不一致，這也可以證明其實它
們並非同一個窗口。這兩個標題分別由 Application.Title和 Main Form（如 Form1）的 Caption
屬性所設置。
另外，還可以通過它們的句柄來了解它們的實質。MainForm（如 Form1）的 Handle
所返回的，是窗體的窗口句柄；Application.Handle 所返回的，卻是這個 0×0 大小的窗口
句柄。
因此，我們可以粗略地認為，Application 其實是一個窗口！

·80·

VCL  庫
4

圖4.4  主窗口標題與任務欄標題不一致注意：Application 是一個 0*0 大小的不可見窗口！
TApplication類的代碼可作為證明。在 TApplication 的構造函數中有這樣一行代碼：
if not IsLibrary then CreateHandle;
在非 DLL 項目中，構造函數會調用 CreateHandle方法。查看該方法源代碼可知，該方
法的任務正是注冊窗口類，並創建一個窗口實例。以下是 CreateHandle 的代碼，請注意其
中所加的注釋：

procedure TApplication.CreateHandle;
var
TempClass: TWndClass;
SysMenu: HMenu;
begin
  if not FHandleCreated and not IsConsole then
begin
    FObjectInstance := Classes.MakeObjectInstance(WndProc);

   // 如果窗口類不存在，則注冊窗口類
    if not GetClassInfo(HInstance,
     WindowClass.lpszClassName,
     TempClass
   ) then
   begin
      WindowClass.hInstance := HInstance;
      if Windows.RegisterClass(WindowClass) = 0 then
      raise EOutOfResources.Create(SWindowClass);
   end;

   // 創建窗口，長度和寬度都是0，位置在屏幕中央，返回的句柄FHandle
   // 也就是Tapplication.Handle的值

·81·

Delphi  高手突破
    FHandle := CreateWindow(WindowClass.lpszClassName,
PChar(FTitle),
      WS_POPUP or WS_CAPTION or WS_CLIPSIBLINGS or WS_SYSMENU
          or WS_MINIMIZEBOX,
      GetSystemMetrics(SM_CXSCREEN) div 2,
      GetSystemMetrics(SM_CYSCREEN) div 2,
     0,
     0,
     0,
     0,
     HInstance,
     Nil
   );

    FTitle := '';
    FHandleCreated := True;

   // 調用SetWindowLong設置窗口的窗口函數（WndProc），下文會詳述
    SetWindowLong(FHandle, GWL_WNDPROC, Longint(FObjectInstance));

    if NewStyleControls then
   begin
      SendMessage(FHandle, WM_SETICON, 1, GetIconHandle);
      SetClassLong(FHandle, GCL_HICON, GetIconHandle);
   end;
    SysMenu := GetSystemMenu(FHandle, False);
    DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
    DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
    If NewStyleControls then
      DeleteMenu(SysMenu, SC_MOVE, MF_BYCOMMAND);
end;
end;

對照一下此前使用純 API 編寫的窗口程序，就會發現一些它們的相似之處。在
CreateHandle()中，可以看到熟悉的 RegisterClass()、CreateWindow()等 API 函數的調用。比
較特別的是，CreateHandle()中通過 API 函數 SetWindowLong()來設置窗口的窗口函數：
SetWindowLong(FHandle, GWL_WNDPROC, Longint(FObjectInstance));
此時，SetWindowLong()的第 3 個參數為窗口函數實例的地址，其中 FObjectInstance
是由 CreateHandle()的第 1行代碼
FObjectInstance := Classes.MakeObjectInstance(WndProc);

·82·

VCL  庫
所創建的實例的指針，而 WndProc()則成了真正的窗口函數。具體關於 WndProc()的實現，
將在 4.4.4 節敘述。
TApplication 本身有一個 private 成員 FMainForm，它指向程序員所定義的主窗體，並
在 TApplication.CreateForm方法中判斷並賦值：

procedure TApplication.CreateForm(InstanceClass: TComponentClass;
4
var Reference);
var
Instance: TComponent;
begin
  Instance := TComponent(InstanceClass.NewInstance);
  …… // 創建窗體實例的代碼省略

// 第一個創建的窗體實例就是MainForm
  if (FMainForm = nil) and (Instance is TForm) then
begin
   TForm(Instance).HandleNeeded;
    FMainForm := TForm(Instance);
end;
end;

因此，Delphi 為每個應用程序自動生成的代碼中就有對 CreateForm的調用，如：
Application.CreateForm(TForm1, Form1);
值得注意的是，如果有一系列的多個 CreateForm的調用，則第一個調用 CreateForm被
創建的窗體，就是整個 Application 的MainForm。這一點從 CreateForm的代碼中不難看出。
在 Project 的Options中設置 MainForm，Delphi 的 IDE 會自動調整代碼。
明白了 Application 的本質之后，再來看一下它是如何建立主消息循環的。
4.4.3  TApplication 創建主消息循環
在 TApplication 的 CreateHandle 方法中可以看到，SetWindowLong()的調用將
TApplication.WndProc 設置成了那個 0×0 大小窗口的窗口函數。
也就是說，在 TApplication 的構造函數中主要完成了兩件事情：注冊窗口類及窗口函
數，創建 Application 窗口實例。
那接下來應該就是進入主消息循環了？是的，這也就是 Application.Run方法所完成的
事情。TApplication 類的Run 方法中有這樣一段代碼：

repeat
try

·83·

Delphi  高手突破
   HandleMessage;
except
   HandleException(Self);
end;
until Terminated;

是的，這就是主消息循環。看上去似乎沒有取消息、分發消息的過程，其實它們都被
包含在 HandleMessage()方法中了。HandleMessage()方法其實是對 ProcessMessage()方法的
調用，而在 ProcessMessage()中就可以看到取消息、分發消息的動作了。以下是 Tapplication
的 ProcessMessage()方法的源代碼，請注意其中的注釋：

function TApplication.ProcessMessage(var Msg: TMsg): Boolean;
var
Handled: Boolean;
begin
  Result := False;
// 取消息
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
    Result := True;
    if Msg.Message <> WM_QUIT then
   begin
      Handled := False;
      if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
     if (
      not IsHintMsg(Msg) and
      not Handled and
      not IsMDIMsg(Msg) and
      not IsKeyMsg(Msg) and
      not IsDlgMsg(Msg)
     ) then
     begin
      // 熟悉的分發消息過程
      TranslateMessage(Msg);
      DispatchMessage(Msg);
     end;
   end
   else
     // 如果取到的消息為WM_QUIT，則將Fterminate設為真
     // 以通知主消息循環退出
     // 這和WindowDemo程序中判斷GetMessage()函數返回值是否為0等效

·84·

VCL  庫
     // 因為GetMessage()函數取出的消息如果是WM_QUIT，它的返回值為0
      FTerminate := True;
end;
end;

ProcessMessage()方法清楚地顯示了從消息隊列取消息並分發消息的過程，並且當取到
的消息為 WM_QUIT 時，則將 FTerminate 置為 True，標志程序退出。  4
4.4.4  窗口函數（WndProc）處理消息
窗口函數是一個回調函數，它被 Windows 系統所調用，其參數會被給出消息編號、消
息參數等信息，以便進行處理。
典型的窗口函數中會包含一個大的 case 分支，以處理不同的消息。
在 4.4.2 節中分析 TApplication.CreateHandle()的代碼時提到過，CreateHandle()將
Application 窗口的窗口函數設置為 WndProc()。那么，現在就來看一下這個 WndProc，請
注意其中的注釋：

procedure TApplication.WndProc(var Message: TMessage);
type // 函數內嵌定義的類型，只限函數內部使用
  TInitTestLibrary = function(Size: DWord; PAutoClassInfo: Pointer):
      Boolean; stdcall;

var
  I: Integer;
  SaveFocus, TopWindow: HWnd;
  InitTestLibrary: TInitTestLibrary;

  // 內嵌函數，默認的消息處理
  // 調用Windows的API 函數DefWindowProc
  procedure Default;
  begin
    with Message do
      Result := DefWindowProc(FHandle, Msg, WParam, LParam);
  end;

  procedure DrawAppIcon;
  var
    DC: HDC;
    PS: TPaintStruct;
  begin
    with Message do

·85·

Delphi  高手突破
    begin
      DC := BeginPaint(FHandle, PS);
      DrawIcon(DC, 0, 0, GetIconHandle);
      EndPaint(FHandle, PS);
    end;
  end;

begin
  try
    Message.Result := 0;
    for I := 0 to FWindowHooks.Count - 1 do
      if TWindowHook(FWindowHooks[I]^)(Message) then Exit;
    CheckIniChange(Message);
    with Message do

      // 開始龐大的case 分支，對不同的消息做出不同的處理
      case Msg of
        WM_SYSCOMMAND:
          case WParam and $FFF0 of
            SC_MINIMIZE: Minimize;
            SC_RESTORE: Restore;
          else
            Default;
          end;
        WM_CLOSE:
          if MainForm <> nil then MainForm.Close;
        WM_PAINT:
          if IsIconic(FHandle) then DrawAppIcon else Default;
        WM_ERASEBKGND:
          begin
            Message.Msg := WM_ICONERASEBKGND;
            Default;
          end;
        WM_QUERYDRAGICON:
          Result := GetIconHandle;
        WM_SETFOCUS:
          begin
            PostMessage(FHandle, CM_ENTER, 0, 0);
            Default;
          end;
        WM_ACTIVATEAPP:
          begin

·86·

VCL  庫
            Default;
            FActive := TWMActivateApp(Message).Active;
            if TWMActivateApp(Message).Active then
            begin
              RestoreTopMosts;
              PostMessage(FHandle, CM_ACTIVATE, 0, 0)
            end  4
            else
            begin
              NormalizeTopMosts;
              PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
            end;
          end;
        WM_ENABLE:
          if TWMEnable(Message).Enabled then
          begin
            RestoreTopMosts;
            if FWindowList <> nil then
            begin
              EnableTaskWindows(FWindowList);
              FWindowList := nil;
            end;
            Default;
          end else
          begin
            Default;
            if FWindowList = nil then
              FWindowList := DisableTaskWindows(Handle);
            NormalizeAllTopMosts;
          end;
        WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
          Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);
        WM_ENDSESSION:
          if TWMEndSession(Message).EndSession then FTerminate := True;
        WM_COPYDATA:
          if (PCopyDataStruct(Message.lParam)^.dwData =
DWORD($DE534454))
            and (FAllowTesting) then
                if FTestLib = 0 then
                begin
                    FTestLib := SafeLoadLibrary('vcltest3.dll');
                    if FTestLib <> 0 then

·87·

Delphi  高手突破
                    begin
                        Result := 0;
                        @InitTestLibrary := GetProcAddress(
                            FTestLib,
                            'RegisterAutomation'
                        );
                        if @InitTestLibrary <> nil then
                            InitTestLibrary(
                               PCopyDataStruct(Message.lParam)^.cbData,
                               PCopyDataStruct(Message.lParam)^.lpData
                            );
                    end
                    else
                    begin
                        Result := GetLastError;
                        FTestLib := 0;
                    end;
                end
                else
                    Result := 0;
        CM_ACTIONEXECUTE, CM_ACTIONUPDATE:
          Message.Result := Ord(DispatchAction(
              Message.Msg,
              TBasicAction(Message.LParam))
          );
        CM_APPKEYDOWN:
          if IsShortCut(TWMKey(Message)) then Result := 1;
        CM_APPSYSCOMMAND:
          if MainForm <> nil then
            with MainForm do
              if (Handle <> 0) and IsWindowEnabled(Handle) and
                IsWindowVisible(Handle) then
              begin
                FocusMessages := False;
                SaveFocus := GetFocus;
                Windows.SetFocus(Handle);
                Perform(WM_SYSCOMMAND, WParam, LParam);
                Windows.SetFocus(SaveFocus);
                FocusMessages := True;
                Result := 1;
              end;
        CM_ACTIVATE:

·88·

VCL  庫
          if Assigned(FOnActivate) then FOnActivate(Self);
        CM_DEACTIVATE:
          if Assigned(FOnDeactivate) then FOnDeactivate(Self);
        CM_ENTER:
          if not IsIconic(FHandle) and (GetFocus = FHandle) then
          begin
            TopWindow := FindTopMostWindow(0);  4
            if TopWindow <> 0 then Windows.SetFocus(TopWindow);
          end;
        WM_HELP,   // MessageBox(... MB_HELP)
        CM_INVOKEHELP: InvokeHelp(WParam, LParam);
        CM_WINDOWHOOK:
          if wParam = 0 then
            HookMainWindow(TWindowHook(Pointer(LParam)^)) else
            UnhookMainWindow(TWindowHook(Pointer(LParam)^));
        CM_DIALOGHANDLE:
          if wParam = 1 then
            Result := FDialogHandle
          else
            FDialogHandle := lParam;
        WM_SETTINGCHANGE:
          begin
            Mouse.SettingChanged(wParam);
            SettingChange(TWMSettingChange(Message));
            Default;
          end;
        WM_FONTCHANGE:
          begin
            Screen.ResetFonts;
            Default;
          end;
        WM_NULL:
          CheckSynchronize;
      else
        Default;
      end;
  except
    HandleException(Self);
  end;
end;

整個 WndProc()方法，基本上只包含了一個龐大的 case 分支，其中給出了每個消息的

·89·

Delphi  高手突破
處理代碼，“WM_”打頭的為 Windows定義的窗口消息，“CM_”打頭的為 VCL庫自定
義的消息。
需要注意的是，這里給出 WndProc 是屬於 TApplication 的，也就是那個 0×0 大小的
Application窗口的窗口函數，而每個 Form另外都有自己的窗口函數。
至此，讀者應該清楚了 VCL 框架是如何封裝 Windows程序框架的了。知道 VCL 為我
們做了什么，它想要提供給我們的是怎樣的一個世界，這對於我們更好地融入 VCL 是大有
好處的。這比從 RAD角度看待 VCL，有了更深一層的理解。好了，關於 VCL 和消息的話
題到此為止。
4.5  TPersistent與對象賦值
在 Object Pascal 中，所有的簡單類型（或稱編譯器內置類型，即非“類”類型，如 Integer、
Cardinal、Char、Record 等類型）的賦值操作所進行的都是位復制，即將一個變量所在的內
存空間的二進制位值復制到被賦值的變量所載的內存空間中。
如定義這樣一個記錄類型：

type
    TExampleRec = record
        Member1 : Integer;
        Member2 : Char;
end;

在代碼中，聲明例如兩個 TExampleRec 類型的變量實體，並在它們之間進行賦值：

var
    A, B : TExampleRec;
begin
    A.Member1 := 1;
    A.Member2 := 'A';
    B := A;
end;

其中，B := A;的結果將導致 A的所有值都被復制到 B 中，A和 B 各自擁有一份它們的
值。查看這段代碼的編譯結果：

mov [esp], $00000001              // A.Member1 := 1;
mov byte ptr [esp + $04], $41   // A.Member2 := ′A′;
mov eax, [esp]                     // B.Member1 := A.Member1
mov [esp + $08], eax

·90·

VCL  庫
mov eax, [esp + $04]              // B.Member2 := A.Member2
mov [esp + $0c], eax

就可以非常清楚地看到：
B := A;
與  4

B.Member1 := A.Member1;
B.Member2 := A.Member2;

是等價的。
對於簡單類型，可以簡單地以變量名稱來進行賦值，那么對於所謂的復雜類型——“類”
類型呢？
此前曾經提到過，Delphi 向 Object Pascal 引入了所謂的“引用/值”模型，即對於簡單
類型的變量，采用“值”模型，它們在程序中的傳遞方式全部是基於“值”進行的。而復
雜類型的變量，即類的實例對象，采用“引用”模型，因此在程序中所有類的對象的傳遞，
全部基於其“引用”，也就是對象的指針。
如果將兩個對象通過名稱直接進行簡單的賦值，將導致對象指針的轉移，而並非復制
它們之間的內存空間的二進制值。例如，將上述的 TExampleRec 改成 Class 類型：

type
    TExample = class
    public
        Member1 : Integer;
        Member2 : Char;
end;

並將賦值的代碼改為：

var
    A, B : TExample;
begin
    A := TExample.Create();
    B := TExample.Create();
    ShowMessage(IntToStr(Integer(A)));  // 輸出13513320
    ShowMessage(IntToStr(Integer(B)));  // 輸出 13513336
    A.Member1 := 1;
    A.Member2 := 'A';
    B := A;

·91·

Delphi  高手突破
    ShowMessage(IntToStr(Integer(B))); // 輸出 13513320
    ......

這段代碼中的 3 個 ShowMessage 調用，將輸出對象所在內存空間的地址值。可以很明
顯看到，第 3 個 ShowMessage 輸出的 B 對象所在的內存地址已經指向了 A 對象所在內存
地址。此時，B 和 A 所使用的數據將是同一份數據，若修改 A 的 Member1 的值，那么 B
的 Member1 也將同時被修改。而原先 B 所在的空間（13513336）已經失去了引用它的指針，
於是就造成了所謂的“內存泄漏”。如圖 4.5 所示。
Object  Object
A  B
B := A;
Object  Object
A  B

圖4.5  B:=A;的結果
可見，簡單、直接地通過對象名稱進行賦值是達不到復制對象的目的的。如果的確需
要復制一個對象，那么難道真的要如同

B.Member1 := A.Member1;
B.Member2 := A.Member2;

這樣來進行嗎？即使可以這樣做，那 private 數據如何復制呢？
可以為類增加一個Assign方法，以進行對象間的復制。例如修改以上的TExample類：

type
    TExample = class
        Member1 : Integer;
        Member2 : Char;
    public
        procedure Assign(Src : TExample);
    end;

·92·

VCL  庫
實現該類的 Assign 方法如下：

procedure TExample.Assign(Src: TExample);
begin
    Member1 := Src.Member1;
    Member2 := Src.Member2;
end;  4

如此便可以進行 TExample 類實例對象間的復制：

var
    A, B : TExample;
begin
    A := TExample.Create();
    B := TExample.Create();
    A.Member1 := 1;
    A.Member2 := 'A';
    B.Assign(A);
......

如此龐大的 VCL 庫中，肯定需要提供這樣一種機制來保證對象間的有效賦值，於是
VCL 提供了一個抽象類——TPersistent。
TPersistent 為對象間的復制式賦值定義了一套接口規范：

  TPersistent = class(TObject)
  private
    procedure AssignError(Source: TPersistent);
  protected
    procedure AssignTo(Dest: TPersistent); virtual;
    procedure DefineProperties(Filer: TFiler); virtual;
    function  GetOwner: TPersistent; dynamic;
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); virtual;
    function  GetNamePath: string; dynamic;
  end;

在TPersistent的聲明中，有兩個Public的方法（Destroy在此不討論），其中GetNamePath
是 Delphi 的集成開發環境內部使用的，VCL 不推薦直接對它的調用。而 Assign 方法則是
為完成對象復制而存在的，並且被聲明為虛方法，以允許每個派生類定義自己的復制對象
的方法。

·93·

Delphi  高手突破
如果正在設計的類需要有這種允許對象復制的能力，則讓類從 TPersistent 派生並重寫
Assign 方法。
如果沒有重寫 Assign 方法，則 TPersistent 的 Assign 方法會將復制動作交給源對象來
進行：

procedure TPersistent.Assign(Source: TPersistent);
begin
  if Source <> nil then
      Source.AssignTo(Self) // 調用源對象的AssignTo方法
  else
      AssignError(nil);
end;

可以在 TPersistent 類的聲明的 protected 節中找到 AssignTo 方法的聲明，它也是一個虛
方法。
如果將復制動作交給源對象來完成，那么必須保證源對象的類已經重寫了 AssignTo方
法，否則將拋出一個“Assign Error”異常：

procedure TPersistent.AssignTo(Dest: TPersistent);
begin
  Dest.AssignError(Self);
end;

procedure TPersistent.AssignError(Source: TPersistent);
var
  SourceName: string;
begin
  if Source <> nil then
    SourceName := Source.ClassName
  else
    SourceName := 'nil';
  raise EConvertError.CreateResFmt(
    @SAssignError,
    [SourceName, ClassName]
  );
end;

AssignError是一個 private 方法，僅僅用於拋出賦值錯誤的異常。
在 TPersistent 的聲明中，GetOwner 方法是被前面所述由 Delphi 內部使用的
GetNamePath 所調用。
最后還剩下一個虛方法 DefineProperties()，它則是為 TPersistent 的另一個使命而存在：

·94·

VCL  庫
對象持久。一個對象要持久存在，就必須將它流化（Streaming），保存到一個磁盤文件（.dfm
文件）中。TPersistent 也使得其派生類具有這種能力，但它作為抽象類只是定義接口而並
沒有給出實現。可以看到，DefineProperties 是一個空的虛方法：

procedure TPersistent.DefineProperties(Filer: TFiler);
begin
4
end;

這留待其派生類來實現。
對於對象持久的實現類，最典型的就是 TComponent，每個組件都具有保存自己的能力。
因此下面將以 TComponent 來說明對象持久的實現，雖然它是在 TPersistent 中定義接口的。
4.6  TComponent與對象持久
Delphi IDE的流系統用來保證所有TPersistent及其派生類的published的數據都會被自
動保存和讀取。而 TComponent 類派生自 TPersistent，所有組件都從 TComponent 派生，因
此所有組件都具有自我保存、持久的能力，這是 Delphi IDE 的流系統所保證的。不過，這
樣的對象持久系統並不完善，至少，它無法保存對象的非 published 數據。
Delphi 當然會為這種情況提供解決方案，它就是 TPersistent 聲明的 DefineProperties()
方法，是一個虛方法。在 TPersistent 的實現中，它是一個空方法。每個 TPersistent 的派生
類需要保存非 published數據的時侯，就可以覆蓋該方法。
VCL 的所有組件被放置在一個 Form 上之后，它的位置就會被記錄下來。保存該
Form，后重新打開，所有放置的組件都還在原來的位置上，包括那些運行時不可見的組件，
如 Ttimer。這些組件並沒有標識位值的“Left”或“Top”屬性，那它們的位置信息是如何
保存的呢？
可以在一個空白的 Form 上放置一個 TTimer 組件，並保存該 Form，然后打開該 Form
的定義文件（如：Form1.dfm），可以看到類似如下的內容：

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 696
  Height = 480
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'

·95·

Delphi  高手突破
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13

  object Timer1: TTimer
    Left = 160
    Top = 64
  end
end

尋找到其中的 object Timer1: TTimer 這一行以及其后的數行：

  object Timer1: TTimer
    Left = 160
    Top = 64
  End

這幾行記錄了TTimer組件，可是很奇怪，TTimer組件本身並沒有所謂的“Left”和“Top”
屬性，為什么在 dfm文件的定義中會出現呢？
“Left”和“Top”並非 TTimer的 published 數據，因此它們肯定不是由 Delphi IDE 的
流系統來保存的。
TTimer 組件派生自 TComponent，而 TComponent 正是通過重寫了 TPersistent 的
DefineProperties()方法來記錄下 Form上面組件的位置。
來查看一下被 Tcomponent 覆蓋（overriding）了的DefineProperties()方法的代碼：

procedure TComponent.DefineProperties(Filer: TFiler);
var
  Ancestor: TComponent;
  Info: Longint;
begin
  Info := 0;
  Ancestor := TComponent(Filer.Ancestor);
  if Ancestor <> nil then Info := Ancestor.FDesignInfo;
  Filer.DefineProperty('Left', ReadLeft, WriteLeft,
    LongRec(FDesignInfo).Lo <> LongRec(Info).Lo);
  Filer.DefineProperty('Top', ReadTop, WriteTop,
    LongRec(FDesignInfo).Hi <> LongRec(Info).Hi);
end;

·96·

VCL  庫
這幾行代碼首先檢查組件本身是否是從其他類派生的，因為如果存在祖先類而派生類
本身沒有改變要保存的屬性值，該屬性值就不必保存了。
然后通過傳進的 TFiler類的參數 Filer來定義要保存的屬性的讀寫方法：

  Filer.DefineProperty('Left', ReadLeft, WriteLeft,
    LongRec(FDesignInfo).Lo <> LongRec(Info).Lo);
4
Filer.DefineProperty('Top', ReadTop, WriteTop,
LongRec(FDesignInfo).Hi <> LongRec(Info).Hi);

Filer.DefineProperty()方法的第 2、第 3 個參數分別是讀寫屬性的方法。這兩個方法的
原型分別如下：

TReaderProc = procedure(Reader: TReader) of object;
TWriterProc = procedure(Writer: TWriter) of object;

TComponent 類為保存“Left”和“Top”屬性，分別提供了 ReadLeft/WriteLeft 和
ReadTop/WriteTop 方法：

procedure TComponent.ReadLeft(Reader: TReader);
begin
  LongRec(FDesignInfo).Lo := Reader.ReadInteger;
end;

procedure TComponent.ReadTop(Reader: TReader);
begin
  LongRec(FDesignInfo).Hi := Reader.ReadInteger;
end;

procedure TComponent.WriteLeft(Writer: TWriter);
begin
  Writer.WriteInteger(LongRec(FDesignInfo).Lo);
end;

procedure TComponent.WriteTop(Writer: TWriter);
begin
  Writer.WriteInteger(LongRec(FDesignInfo).Hi);
end;

因此，每個 TComponent的實例在被流化到 dfm文件時，都會有 Left 和Top 屬性，即
使組件並沒有這兩個屬性。

·97·

Delphi  高手突破
4.7  TCanvas 與Windows GDI
Windows 是一個圖形操作系統，提供所謂的 GUI（圖形用戶界面）。為了使程序員能
夠實現 GUI 的程序，Windows提供了一套 GDI（圖形設備接口）的 API 函數。
VCL 作為對 Windows API 封裝的框架類庫，當然也對 GDI 進行了封裝。GDI 作為
Windows API 的一個子集，本身卻也非常龐大，涉及了與各種圖形相關的內容，如畫筆
（Pens）、刷子（Brushes）、設備上下文（Device Contexts）、位圖（Bitmap）以及字體、
顏色等。在 VCL 中，與GDI 相關的類、函數基本都被實現在 Graphics.pas的單元中。
常用的 GDI 對象無非就是畫筆、刷子、位圖等，VCL 首先對這些 GDI 的基本對象進
行了抽象，然后以這些基本對象輔助 TCanvas實現對 GDI 的全面封裝。
下面，先來研究一下那些基本對象——TPen、TBrush。
4.7.1  TPen
Windows中，創建一個筆（Pen）對象，使用 API 函數 CreatePenIndirect()或 CreatePen()。
CreatePen()的原型如下：

HPEN CreatePen(
    int fnPenStyle,    // Pen風格
    int nWidth,         // 寬度
    COLORREF crColor  // 顏色
);

該函數返回一個筆對象的句柄。
要在窗口上畫出一條兩個像素寬度的紅色直線，使用 Windows API來完成的代碼可能
是這樣的：

var
    hOldPen : HPEN;
    hNewPen : HPEN;
    DC : HDC;
begin
    DC := GetDC(Handle);
    hNewPen := CreatePen(PS_SOLID, 2, RGB(255, 0, 0));
    hOldPen := SelectObject(DC, hNewPen);
    LineTo(DC, 100, 100);
    SelectObject(DC, hOldPen);
    DeleteObject(hNewPen);
    ReleaseDC(Handle, DC);

·98·

VCL 庫
end;

這段代碼首先獲取窗口的“設備上下文句柄”（HDC）。
然后調用 API 函數 CreatePen()創建一個寬度為 2像素、顏色為紅色（RGB（255, 0, 0））
的筆對象。
接着，調用 API 函數 SelectObject()將所創建的筆對象選擇為當前對象。需要注意的是，
4
此時必須將 SelectObject()函數所返回的原先的 GDI 對象保存起來，在使用完創建的新的
GDI 對象后，要將它還原回去，否則就會發生 GDI 資源泄漏。
再接着，調用 API 函數 LineTo()畫出一條直線。
完成任務，然后就是收尾工作。首先選擇還原 GDI 對象，並調用 API 函數 DeleteObject()
刪除所創建的筆對象。最后不要忘記調用 API 函數 ReleaseDC 以釋放窗口的 HDC。
經過這一系列步驟，終於在窗口上畫出了一條寬度為 2 像素的紅色直線。並且，此過
程中不允許有任何的疏漏，因為稍有不慎，便會導致 GDI 資源泄漏。而我們知道，Windows
的窗口經常需要被重新繪制（如被其他窗口擋住又重新出現時），GDI 資源泄漏的速度將
是非常快的。
如果將以上這段代碼寫在某個 Form 的 OnPaint 事件中，並且刪除 DeleteObject()那行
代碼（假設漏寫了這行），然后運行程序，拖着 Form在桌面上晃幾下，不用多久，Windows
的 GDI 資源就會消耗殆盡，這在 Windows 95/98系統中表現得尤為明顯。在 Windows 2000
中可以如此。
不妨試一下，在 Windows 2000 中打開“任務管理器”窗口，並選擇顯示“GDI 對象”
這一列。隨着鼠標的晃動，該程序所使用的 GDI 對象數飛快上升（初始為 31），很快就升
到如圖 4.6 所示的情況。

圖4.6 GDI資源迅速泄漏

·99·

Delphi  高手突破
可見，使用最原始的 API 來寫圖形界面，既低效，又不安全。而 VCL 將 Windows GDI
的 Pen 對象抽象為 TPen類，使得在窗口上作圖非常方便並且安全。
來看一下 TPen 類的聲明：

  TPen = class(TGraphicsObject)
  private
    FMode: TPenMode;
    procedure GetData(var PenData: TPenData);
    procedure SetData(const PenData: TPenData);
  protected
    function GetColor: TColor;
    procedure SetColor(Value: TColor);
    function GetHandle: HPen;
    procedure SetHandle(Value: HPen);
    procedure SetMode(Value: TPenMode);
    function GetStyle: TPenStyle;
    procedure SetStyle(Value: TPenStyle);
    function GetWidth: Integer;
    procedure SetWidth(Value: Integer);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property Handle: HPen read GetHandle write SetHandle;
  published
    property Color: TColor read GetColor write SetColor default clBlack;
    property Mode: TPenMode read FMode write SetMode default pmCopy;
    property Style: TPenStyle read GetStyle write SetStyle default
psSolid;
    property Width: Integer read GetWidth write SetWidth default 1;
  end;

TPen 基本上將 API 函數 CreatePen()的 3 個參數都作為 TPen 的屬性，使用 TPen 只需
創建 TPen 的實例並且設置這些屬性即可。同樣畫一條寬度為 2 像素的紅色直線，使用 TPen
的代碼就會是這樣的：

Canvas.Pen.Color := clRed;
Canvas.Pen.Width := 2;
Canvas.PenPos := Point(0, 0);
Canvas.LineTo(100, 100);

·100·

VCL  庫
這里的代碼使用了 TCustomForm的 Canvas 屬性的Pen 子對象。關於 Canvas將在 4.7.3
節中詳述，此處可以將它當作一個創建好了 TPen 實例對象的一個對象。
這些代碼顯然易懂得多，而且很安全，不需要擔心資源泄漏的情況。
現在已經可以明顯體會到 TPen 的優越之處。不過，此處的重點並非要知道 TPen 有多
好用，而是要知道 TPen是如何封裝 Windows GDI中的 Pen 對象的。
當調用
4
Pen := TPen.Create()
后，就創建了一個 TPen的實例。那么 TPen 的構造函數做了什么呢？

constructor TPen.Create;
begin
  FResource := PenManager.AllocResource(DefPenData);
  FMode := pmCopy;
end;

在這里，可以發現 PenManager 的存在。為了不干擾視線，可以把它當作一個 GDI 資
源的管理器。其實，它的類型正是 TResourceManager類。
在 VCL 的 Graphics.pas單元中，定義了同樣的 3個資源管理器：

var
  FontManager: TResourceManager;
  PenManager: TResourceManager;
  BrushManager: TResourceManager;

PenManager正是其中一個管理 Pen資源的管理器。它內部維護了一個已經分配了所有
類型的 Pen的列表，當如同這樣：
FResource := PenManager.AllocResource(DefPenData);
當調用它的 AllocResource()方法時，它會在其內部列表中尋找是否已經分配了同類型
的 Pen，如果有，則增加該類型的 Pen的引用計數；如果沒有，則分配一個新的類型的 Pen：

function TResourceManager.AllocResource(const ResData): PResource;
var
  ResHash: Word;
begin
  ResHash := GetHashCode(ResData, ResDataSize);
  Lock;
  try
    Result := ResList;

·101·

Delphi  高手突破
    while (Result <> nil) and ((Result^.HashCode <> ResHash) or
      not CompareMem(@Result^.Data, @ResData, ResDataSize)) do
      Result := Result^.Next;
    if Result = nil then
    begin // 沒找到，則分配
      GetMem(Result, ResDataSize + ResInfoSize);
      with Result^ do
      begin
        Next := ResList;
        RefCount := 0;
        Handle := TResData(ResData).Handle;
        HashCode := ResHash;
        Move(ResData, Data, ResDataSize);
      end;
      ResList := Result;
    end;
    Inc(Result^.RefCount); // 增加引用計數
  finally
    Unlock;
  end;
end;

TPen 的構造函數其實就是為其實例申請一塊內存以存放該 Pen 的一些屬性。該塊內存
為 TPenData 記錄類型：

  TPenData = record
    Handle: HPen;
    Color: TColor;
    Width: Integer;
    Style: TPenStyle;
  end;

該記錄對應於 API 函數 CreatePen()要求定義的 Pen 的屬性，其中 Handle 為 Windows
中該 Pen 的句柄。
FResource := PenManager.AllocResource(DefPenData);
中的 DefPenData參數，其類型就是該記錄類型的，該變量定義了 Pen的默認屬性：

const
  DefPenData: TPenData = (
    Handle: 0;

·102·

VCL  庫
    Color: clBlack;
    Width: 1;
    Style: psSolid);

因此，TPen的構造函數完成了 Pen的資源分配，不過該 Pen 的句柄為 0，這是因為並
沒有真正向 Windows 申請創建一個 GDI 的 Pen 對象（畢竟一旦申請，就要耗費一個 GDI
4
對象，而 Windows中，GDI 資源是很寶貴的）。
當真正需要使用 Pen 時，就需要將向 Windows申請而獲得的 Pen 對象的句柄賦給 VCL
的 Pen 對象。這就是通過其 Handle屬性進行的。從 TPen 的聲明
property Handle: HPen read GetHandle write SetHandle;
中可以看到，當設置該屬性時會調用 SetHandle()方法；當讀取該屬性時，會通過調用
GetHandle()方法來獲得。
SetHandle()方法將句柄傳遞給 TPen 實例的那個 TPenData 記錄：

procedure TPen.SetHandle(Value: HPen);
var
  PenData: TPenData;
begin
  PenData := DefPenData;
  PenData.Handle := Value;
  SetData(PenData);
end;

而在 GetHandle()方法中，將判斷其句柄是否為 0。如果為 0，則說明還沒有真正向
Windows申請創建過 Pen 對象，此時會真正地調用 API 函數 CreatePenIndirect()來創建（該
函數與 CreatePen()差不多，區別只在於通過一個結構參數來指定該 Pen 的屬性）一個 GDI
的 Pen 對象，並返回其句柄；如果不為 0，則直接返回該句柄：

function TPen.GetHandle: HPen;
const
  PenStyles: array[TPenStyle] of Word =
    (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
     PS_INSIDEFRAME);
var
  LogPen: TLogPen;
begin
  with FResource^ do
  begin
    if Handle = 0 then

·103·

Delphi  高手突破
    begin
      PenManager.Lock;
      with LogPen do
      try
        if Handle = 0 then
        begin
          lopnStyle := PenStyles[Pen.Style];
          lopnWidth.X := Pen.Width;
          lopnColor := ColorToRGB(Pen.Color);
          Handle := CreatePenIndirect(LogPen); // 創建一個GDI的Pen對象
        end;
      finally
        PenManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

TPen 的其他屬性（如 Color、Width 等）都是通過更改 TPen 內部的 TPenData 記錄類
型的數據來實現的。TPen 的對象實例真正起作用是作為 TCanvas 類的對象的子對象來發揮
的，這些在 4.7.3 節講述 TCanvas 類時會詳細展開。
4.7.2  TBrush
VCL 用 TPen 封裝了 Windows GDI 的 Pen 對象，而另一個主角 Brush 則也是一樣，VCL
用 TBrush 封裝了 Windows GDI的 Brush 對象。
Pen 對象用於在窗口上繪制線條，而 Brush 對象則用於填充區域。
同樣，先來看一下使用 GDI 的 Brush 對象是如何在窗口上繪圖的。
Windows 的 GDI API 提供了一個 CreateBrushIndirect()函數用來創建 Brush 對象。
CreateBrushIndirect()函數的原型如下：

HBRUSH CreateBrushIndirect(
  CONST LOGBRUSH *lplb
);

其中的 LOGBRUSH 結構類型的參數指定了刷子的一些信息：

typedef struct tagLOGBRUSH {
  UINT     lbStyle;
  COLORREF lbColor;

·104·

VCL  庫
  LONG     lbHatch;
} LOGBRUSH, *PLOGBRUSH;

在 Delphi 的Graphics.pas中，有該類型定義的 Pascal 語言版本：

  tagLOGBRUSH = packed record
    lbStyle: UINT;  4
    lbColor: COLORREF;
    lbHatch: Longint;
  end;

例如，需要將窗口的（0，0，100，100）的正方形區域填充成紅色，則使用 GDI 的代
碼可能是這樣的：

var
    lb : LOGBRUSH;
    hNewBrush : HBRUSH;
    hWndDC : HDC;
    R : TRect;
begin
    // 設置刷子參數
    lb.lbStyle := BS_SOLID;
    lb.lbColor := clRed;
    lb.lbHatch := HS_VERTICAL;
    // 創建刷子對象
    hNewBrush := CreateBrushIndirect(lb);
    // 取得窗口的設備上下文句柄（HDC）
    HWndDC := GetDC(Handle);
    R := Rect(0, 0, 100, 100);
    // 用刷子填充對象
    FillRect(hWndDC, R, hNewBrush);
    // 刪除所創建的刷子對象並釋放HDC
    DeleteObject(hNewBrush);
    ReleaseDC(Handle, hWndDC);
end;

VCL 的 TBrush 類則對 GDI 的 Brush 進行了封裝。TBrush 的聲明如下：

  TBrush = class(TGraphicsObject)
  private
    procedure GetData(var BrushData: TBrushData);

·105·

Delphi  高手突破
    procedure SetData(const BrushData: TBrushData);
  protected
    function GetBitmap: TBitmap;
    procedure SetBitmap(Value: TBitmap);
    function GetColor: TColor;
    procedure SetColor(Value: TColor);
    function GetHandle: HBrush;
    procedure SetHandle(Value: HBrush);
    function GetStyle: TBrushStyle;
    procedure SetStyle(Value: TBrushStyle);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property Bitmap: TBitmap read GetBitmap write SetBitmap;
    property Handle: HBrush read GetHandle write SetHandle;
  published
    property Color: TColor read GetColor write SetColor default clWhite;
    property Style: TBrushStyle read GetStyle write SetStyle
        default bsSolid;
  end;

不難發現 TBrush 和 TPen非常相似，同樣將 GDI 的 Brush 對象的風格抽象成屬性，並
且構造函數與析構函數所做的工作也與 TPen 的差不多。只不過，這次 GDI 資源的管理器
不是 PenManager，而改成了 BrushManager，但 BrushManager 與 PenManager 其實都是
TResourceManager類的一個實例。
其實，不僅僅是 TBrush 與 TPen 之間，基本 GDI 對象在 VCL 中，其資源管理策略都
是類似的，因此它們的構造函數也就會如此雷同。如 TBrush：

constructor TBrush.Create;
begin
  FResource := BrushManager.AllocResource(DefBrushData);
end;

它同樣是調用了TResourceManager類的AllocResource()方法來分配一個內存空間以存
放一個表示“刷子”默認屬性的數據結構。關於AllocResource()，在講述 TPen 時已經介紹
過了，此處不再重復。
除了資源管理的實現上，在其他方面，包括抽象的方法，TBrush 與TPen 也同樣類似。
例如只有在 GetHandle()方法中才調用 CreateBrushIndirect()去真正創建一個 GDI 的 Brush
對象：

·106·

VCL  庫
function TBrush.GetHandle: HBrush;
var
  LogBrush: TLogBrush;
begin
  with FResource^ do
  begin
    if Handle = 0 then  4
    begin
      BrushManager.Lock;
      try
        if Handle = 0 then
        begin
          with LogBrush do
          begin
            if Brush.Bitmap <> nil then
            begin
              lbStyle := BS_PATTERN;
              Brush.Bitmap.HandleType := bmDDB;
              lbHatch := Brush.Bitmap.Handle;
            end else
            begin
              lbHatch := 0;
              case Brush.Style of
                bsSolid: lbStyle := BS_SOLID;
                bsClear: lbStyle := BS_HOLLOW;
              else
                lbStyle := BS_HATCHED;
                lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
              end;
            end;
            lbColor := ColorToRGB(Brush.Color);
          end;
          Handle := CreateBrushIndirect(LogBrush);
        end;
      finally
        BrushManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

·107·

Delphi  高手突破
此處對 CreateBrushIndirect()的調用與此前直接使用 GDI API 的例子相比，惟一的區別
在於參數的第 3 個域的賦值。此前的例子中，我們給 Brush 的信息的賦值是這    樣的：

lb.lbStyle := BS_SOLID;
lb.lbColor := clRed;
lb.lbHatch := HS_VERTICAL;

第 3 個參數給的是 Brush 的“開口方向”，而 VCL 的 TBrush 中，對 API 封裝需要考
慮各種情況，而且 TBrush 允許將“刷子”和一個位圖聯系起來，因此該參數的決定也比較
復雜。

  with LogBrush do
  begin
    // 如果“刷子”以位圖方式創建，則將位圖句柄作為該參數的值
    if Brush.Bitmap <> nil then
    begin
      lbStyle := BS_PATTERN;
      Brush.Bitmap.HandleType := bmDDB;
      lbHatch := Brush.Bitmap.Handle;
    end else
    // 如果“刷子”並非以位圖方式創建，則……
    begin
      lbHatch := 0;
      case Brush.Style of
        bsSolid: lbStyle := BS_SOLID;  // “實心刷子”
        bsClear: lbStyle := BS_HOLLOW; // “透明”
      else
        lbStyle := BS_HATCHED;
        lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
      end;
    end;
    lbColor := ColorToRGB(Brush.Color);
  end;

TBrush 與 TPen 同樣是為了配合 TCanvas 的，其作用會在 4.7.3 節 TCanvas 中展開。
GDI 的基本對象當然不止 Pen 與Brush，還包括字體、位圖等。不過，它們在 VCL中的抽
象方法與 TPen 和 TBrush 大同小異，在此不再一一介紹。如果對這方面內容感興趣，可以
參考 graphics.pas單元中的代碼。

·108·

VCL  庫
4.7.3  TCanvas
VCL 除了封裝 GDI 的對象（如 Pen和 Brush）以外，也同時封裝了 GDI 的繪圖設備。
VCL 將 GDI 的設備抽象成一個畫布（Canvas），使得我們可以在其上任意作畫。TCanvas
類就是這個畫布的抽象。
先來看一下 TCanvas 類的聲明：  4

  TCanvas = class(TPersistent)
  private
    FHandle: HDC;
    State: TCanvasState;
    FFont: TFont;
    FPen: TPen;
    FBrush: TBrush;
    FPenPos: TPoint;
    FCopyMode: TCopyMode;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    FLock: TRTLCriticalSection;
    FLockCount: Integer;
    FTextFlags: Longint;
    procedure CreateBrush;
    procedure CreateFont;
    procedure CreatePen;
    procedure BrushChanged(ABrush: TObject);
    procedure DeselectHandles;
    function GetCanvasOrientation: TCanvasOrientation;
    function GetClipRect: TRect;
    function GetHandle: HDC;
    function GetPenPos: TPoint;
    function GetPixel(X, Y: Integer): TColor;
    procedure FontChanged(AFont: TObject);
    procedure PenChanged(APen: TObject);
    procedure SetBrush(Value: TBrush);
    procedure SetFont(Value: TFont);
    procedure SetHandle(Value: HDC);
    procedure SetPen(Value: TPen);
    procedure SetPenPos(Value: TPoint);
    procedure SetPixel(X, Y: Integer; Value: TColor);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;

·109·

Delphi  高手突破
    procedure CreateHandle; virtual;
    procedure RequiredState(ReqState: TCanvasState);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap;
      const Source: TRect; Color: TColor);
    procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    procedure CopyRect(const Dest: TRect; Canvas: TCanvas;
      const Source: TRect);
    procedure Draw(X, Y: Integer; Graphic: TGraphic);
    procedure DrawFocusRect(const Rect: TRect);
    procedure Ellipse(X1, Y1, X2, Y2: Integer); overload;
    procedure Ellipse(const Rect: TRect); overload;
    procedure FillRect(const Rect: TRect);
    procedure FloodFill(X, Y: Integer; Color: TColor;
        FillStyle: TFillStyle);
    procedure FrameRect(const Rect: TRect);
    function HandleAllocated: Boolean;
    procedure LineTo(X, Y: Integer);
    procedure Lock;
    procedure MoveTo(X, Y: Integer);
    procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    procedure Polygon(const Points: array of TPoint);
    procedure Polyline(const Points: array of TPoint);
    procedure PolyBezier(const Points: array of TPoint);
    procedure PolyBezierTo(const Points: array of TPoint);
    procedure Rectangle(X1, Y1, X2, Y2: Integer); overload;
    procedure Rectangle(const Rect: TRect); overload;
    procedure Refresh;
    procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
    procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
    function TextExtent(const Text: string): TSize;
    function TextHeight(const Text: string): Integer;
    procedure TextOut(X, Y: Integer; const Text: string);
    procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string);
    function TextWidth(const Text: string): Integer;
    function TryLock: Boolean;
    procedure Unlock;
    property ClipRect: TRect read GetClipRect;
    property Handle: HDC read GetHandle write SetHandle;
    property LockCount: Integer read FLockCount;
    property CanvasOrientation: TCanvasOrientation read

·110·

VCL  庫
        GetCanvasOrientation;
    property PenPos: TPoint read GetPenPos write SetPenPos;
    property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
    property TextFlags: Longint read FTextFlags write FTextFlags;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  published
4
    property Brush: TBrush read FBrush write SetBrush;
    property CopyMode: TCopyMode read FCopyMode write FCopyMode
        default cmSrcCopy;
    property Font: TFont read FFont write SetFont;
    property Pen: TPen read FPen write SetPen;
  end;

在上述的 TPen 和 Tbrush介紹中提到過的使用 GDI API 直接繪圖的代碼示例中，都有
類似這樣的一行代碼：
DC := GetDC(Handle);
這行代碼從一個窗口句柄獲取該窗口的“設備上下文句柄”（HDC），以便使用 GDI
函數在該窗口上進行繪圖。
TCanvas 作為一個“畫布”的抽象，必定需要一個“設備上下文句柄”。TCanvas 中
private的 FHandle 數據成員就是保存這個“設備上下文句柄”的，並且通過 public的 Handle
屬性的 GetHandle()和 SetHandle()方法來對其進行訪問。
TCanvas 內部還擁有各種 GDI 基礎對象的抽象，如 TPen、TBrush、TFont這樣的子對
象，並且在 TCanvas 的構造函數中便創建它們的實例：

constructor TCanvas.Create;
begin
  inherited Create;
  InitializeCriticalSection(FLock);
  FFont := TFont.Create;
  FFont.OnChange := FontChanged;
  FFont.OwnerCriticalSection := @FLock;
  FPen := TPen.Create;
  FPen.OnChange := PenChanged;
  FPen.OwnerCriticalSection := @FLock;
  FBrush := TBrush.Create;
  FBrush.OnChange := BrushChanged;
  FBrush.OwnerCriticalSection := @FLock;
  FCopyMode := cmSrcCopy;
  State := [];
  CanvasList.Add(Self);
end;

·111·

Delphi  高手突破
另外，TCanvas 提供了對應於 GDI 繪圖 API 的各種方法，包括在“畫布”上繪制各種
形狀的方法，如 LineTo()（畫直線）、Rectangle()（畫矩形）、Ellipse()（畫圓/橢圓）以及
直接貼位圖的 Draw()等。
在此以畫直線為例，跟蹤一下 TCanvas 的執行路線，看它是在何時以何種方式調用相
應的 GDI API來完成的。
首先，TCanvas 在構造函數中創建了 TPen 子對象的實例 FPen：
FPen := TPen.Create;
然后，TCanvas 的客戶需要將一個窗口的“設備上下文句柄”（HDC）設置給 Canvas
實例 Handle屬性。TCanvas 自己是無法提供這個 Handle 屬性的值的，雖然 TCanvas聲明了
一個虛方法 CreateHandle()，但該方法在 TCanvas 中的實現是空的。不過，一般在使用
TCanvas 時，都是通過某個組件（如 TForm）的 Canvas 屬性來使用的（這類組件的 Canvas
屬性其實是一個 TCanvas 的實例對象），因此其 Handle 屬性並不需要我們來設置，而是由
組件來完成的。至於空的虛方法 CreateHandle()的作用，以及在組件中使用 Canvas 屬性，
這些會在 4.8節再提及。
在設置 Handle 屬性時，會調用 TCanvas.SetHandle()方法：

procedure TCanvas.SetHandle(Value: HDC);
begin
  if FHandle <> Value then
  begin
    if FHandle <> 0 then
    begin
      DeselectHandles;
      FPenPos := GetPenPos;
      FHandle := 0;
      Exclude(State, csHandleValid);
    end;
    if Value <> 0 then
    begin
      Include(State, csHandleValid);
      FHandle := Value;
      SetPenPos(FPenPos);
    end;
  end;
end;

在 SetHandle()方法中，除了設置 FHandle 的值外，還會調用 SetPenPos()方法設置“畫
筆”的起始坐標點。
接着，客戶程序可以使用 TCanvas的 LineTo()方法來使用畫筆進行畫線：

·112·

VCL  庫
procedure TCanvas.LineTo(X, Y: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.LineTo(FHandle, X, Y);
  Changed;
end;  4

在 LineTo()方法中，首先調用 RequiredState()方法，在 RequiredState()方法中，會再調
用 CreatePen()方法來選中當前的畫筆對象：

procedure TCanvas.CreatePen;
const
  PenModes: array[TPenMode] of Word =
    (R2_BLACK, R2_WHITE, R2_NOP, R2_NOT, R2_COPYPEN, R2_NOTCOPYPEN,
     R2_MERGEPENNOT, R2_MASKPENNOT, R2_MERGENOTPEN, R2_MASKNOTPEN,
     R2_MERGEPEN, R2_NOTMERGEPEN, R2_MASKPEN, R2_NOTMASKPEN, R2_XORPEN,
     R2_NOTXORPEN);
begin
  SelectObject(FHandle, Pen.GetHandle);
  SetROP2(FHandle, PenModes[Pen.Mode]);
end;

在 CreatePen()方法中，執行了 API 函數 SelectObject()，將 Pen對象選為當前畫筆對象。
最后，LineTo()方法中調用 API 函數 LineTo()來畫出直線：
Windows.LineTo(FHandle, X, Y);
由於在 Graphics.pas 單元中發生了“LineTo”這樣的名稱沖突，因此，在真正調用
Windows API的 LineTo()函數時，在其前指明了命名空間（單元名）“Windows.”。
好了，直線畫出來了。除了畫直線，其他圖形的操作原理類似，不再贅述。
4.8  TGraphicControl/TcustomControl
與畫布（Canvas）
VCL 中，TCotnrol 之下的組件分兩條路各行其道。一條為圖形組件，這類組件並非窗
口，職責只在於顯示圖形、圖像，其基類是 TGraphicControl；另一條為窗口組件，這類組
件本身是一個 Windows窗口（有窗口句柄），其基類是 TWinControl。
TGraphicControl 作為顯示圖形、圖像的組件分支，從其開始就提供了一個 TCanvas類
型的 Canvas屬性，以便在組件上繪制圖形、顯示圖像。

·113·

Delphi  高手突破
對於窗口組件的分支，TWinControl 並沒有提供 Canvas 屬性，而在其派生類
TCustomControl 才開始提供 Canvas屬性。如圖 4.7所示。
TControl
TGraphicControl TWinControl
TCustomControl

圖4.7  控件類分支
TGraphicControl 與 TCustomControl 的實現都在 Controls.pas 單元中，它們的聲明看上
去也是如此相似：

  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;

  TCustomControl = class(TWinControl)
  private
    FCanvas: TCanvas;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    property Canvas: TCanvas read FCanvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

·114·

VCL  庫
它們提供了 Canvas屬性，只不過此時 Canvas屬性被隱藏在 protected 節中，它們的派
生類可以選擇性地將其 publish。
由於 TGraphicControl 與 TCustomControl 在有關 Canvas 熟悉的實現上也非常相似，在
此只以 TGraphicControl的實現來講解“畫布”屬性。
由 TGraphicControl 的聲明中的
property Canvas: TCanvas read FCanvas;  4
可知 Canvas 是一個只讀屬性，其載體是 private 的成員對象 FCanvas。FCanvas 在
TGraphicControl 的構造函數中被創建：

constructor TGraphicControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;

在此需要注意的是，FCanvas 在聲明時，是被聲明為 TCanvas 類型的，而在創建時，
卻創建了 TControlCanvas 的示例。其實，TControlCanvas 是 TCanvas 的派生類，它提供了
一些額外的屬性和事件來輔助在 Control（控件）上提供“畫布”屬性。
這里暫停一下，先來看一下 TcontrolCanvas：

  TControlCanvas = class(TCanvas)
  private
    FControl: TControl;
    FDeviceContext: HDC;
    FWindowHandle: HWnd;
    procedure SetControl(AControl: TControl);
  protected
    procedure CreateHandle; override;
  public
    destructor Destroy; override;
    procedure FreeHandle;
    procedure UpdateTextFlags;
    property Control: TControl read FControl write SetControl;
  end;

TControlCanvas將 Canvas綁定到一個 TControl 實例上，其內部的 FControl指針即指向
Canvas所屬的 TControl 實例。
記得 4.7 節中講過，TCanvas 提供了一個空的虛方法 CreateHandle()。這個虛方法在

·115·

Delphi  高手突破
TControlCanvas中被覆蓋重新實現：

procedure TControlCanvas.CreateHandle;
begin
  if FControl = nil then inherited CreateHandle else
  begin
    if FDeviceContext = 0 then
    begin
      with CanvasList.LockList do
      try
        if Count >= CanvasListCacheSize then FreeDeviceContext;
        FDeviceContext := FControl.GetDeviceContext(FWindowHandle);
        Add(Self);
      finally
        CanvasList.UnlockList;
      end;
    end;
    Handle := FDeviceContext;
    UpdateTextFlags;
  end;
end;

在 CreateHandle()方法中，如果 FControl 是 TWinControl 或其派生類的實例，即控件本
身是窗口，則取得該窗口的設備上下文句柄賦給 Handle 屬性；如果 FControl 非 TWinControl
或其派生類的實例，即控件本身並非窗口，則將其父窗口的設備上下文句柄賦給 Handle。
這些都是通過 TControl 聲明的虛函數 GetDeviceContext()實現的，因為 TWinControl 覆蓋重
新實現了 GetDeviceContext()。
說完 TControlCanvas，下面繼續剛才的話題。TGraphicControl 的構造函數中創建了
TControlCanvas實例並賦給 FCanvas。構造函數的最后一行代碼
TControlCanvas(FCanvas).Control := Self;
將 Canvas屬性綁定到了控件本身。
然后，TGraphicControl 定義了一個處理 WM_PAINT Windows消息的消息處理函數：
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
在 WMPaint()方法中，根據接受到的消息的參數所給出的窗口的設備上下文句柄，給
Canvas屬性的 Handle 重新賦值，並且調用虛方法 Paint()：

procedure TGraphicControl.WMPaint(var Message: TWMPaint);
begin
  if Message.DC <> 0 then

·116·

VCL  庫
  begin
    Canvas.Lock;
    try
      Canvas.Handle := Message.DC;
      try
        Paint;
      finally  4
        Canvas.Handle := 0;
      end;
    finally
      Canvas.Unlock;
    end;
  end;
end;

虛方法 Paint()可以被 TGraphicCotnrol的派生類所覆蓋，重新定義並實現繪制圖形、圖
像的方法，並且 TGraphicControl 的派生的實例總是可以放心使用其 Canvas 屬性，而不必
自行獲得窗口的設備上下文句柄。而虛方法 Paint()在 TGraphicControl 中的實現也只是一個
空方法而已。
4.9 節中將講述 TGraphicControl/TCustomControl 的虛方法 Paint()是如何被它們的派生
類所使用來進行窗口重繪的。
4.9  TCustomPanel 與窗口重繪
TCustomPanel 派生自 TCustomControl，是所有 Panel 類組件的基類。TCustomPanel 與
4.8 節中所述的 TGraphicControl 非常類似，只是 TCustomControl 派生自 TWinControl，所
以它的實例是一個窗口。
TCustomControl 與 TGraphicControl 一樣，擁有一個空的虛方法 Paint()，以便讓派生類
決定如何重繪窗口。
現在就來看一下TcustomPanel。它從TCustomControl派生，並且覆蓋重新實現了Paint()
方法。在此，我們不關心 TCustomPanel 所實現的其他特性，而只關注其實現的 Paint()方法。
TCustomPanel 實現的 Paint()方法負責將組件窗口繪制出一個 Panel 效果（邊框、背景和標
題）。先來看一下 Paint()方法：

procedure TCustomPanel.Paint;
const
  Alignments: array[TAlignment] of Longint = (
      DT_LEFT,
      DT_RIGHT,

·117·

Delphi  高手突破
      DT_CENTER
  );
var
  Rect: TRect;
  TopColor, BottomColor: TColor;
  FontHeight: Integer;
  Flags: Longint;

  procedure AdjustColors(Bevel: TPanelBevel);
  begin
    TopColor := clBtnHighlight;
    if Bevel = bvLowered then TopColor := clBtnShadow;
    BottomColor := clBtnShadow;
    if Bevel = bvLowered then BottomColor := clBtnHighlight;
  end;

begin
  Rect := GetClientRect;
  // 畫邊框
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, Rect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  end;
  with Canvas do
  begin
    // 畫背景
    Brush.Color := Color;
    FillRect(Rect);
    Brush.Style := bsClear;
    // 寫標題
    Font := Self.Font;
    FontHeight := TextHeight('W');
    with Rect do
    begin
      Top := ((Bottom + Top) - FontHeight) div 2;
      Bottom := Top + FontHeight;

·118·

VCL  庫
    end;
    Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[FAlignment];
    Flags := DrawTextBiDiModeFlags(Flags);
    DrawText(Handle, PChar(Caption), -1, Rect, Flags);
  end;
end;
  4
Paint()方法含有一個內嵌函數 AdjustColors()，其作用是確定邊框的上下線條顏色（一
條邊框由兩個像素寬度的直線構成，形成立體效果）。
TCustomPanel 使用其基類（TCustomControl）提供的 Canvas屬性，覆蓋其基類定義的
虛方法 Paint()，完成了窗口重繪過程。
在自己編寫組件時，如果需要在組件表面繪制圖形、圖像的話，就可以如同
TCustomPanel 一樣，覆蓋重新實現 Paint()方法。同時，使用基類提供的 Canvas 屬性，對於
繪圖過程來說，也是非常簡單的。
由此 VCL 完全封裝了 Windows的 GDI 功能，並提供了一個簡單、易用的接口。
4.10  TCustomForm與模態窗口
TCustomForm是 Windows 窗口（一般窗口與對話框）的基類。它有兩個顯示窗口的方
法：Show()和 ShowModal()分別用來顯示非模態與模態的窗口。不過，它對於模態窗口的
實現並沒有利用 Windows 系統提供的 DialogBox()之類的 API，而是 VCL 自己實現的。原
因可能是無法將 DialogBox()與 VCL的 Form機制很好地結合。
這一節來研究一下 Show()和 ShowModal()的具體實現。
先是 Show()：

procedure TCustomForm.Show;
begin
  Visible := True;
BringToFront;
end;

Show()的代碼非常簡單，而且易懂，它的行為與其名稱一樣的單純。
而 ShowModal()要做的事情則多得多：

function TCustomForm.ShowModal: Integer;
var
  …… // 省略變量聲明
begin
  …… // 省略部分代碼

·119·

Delphi  高手突破
try
   Show; // 調用Show()方法顯示窗口
   try
      SendMessage(Handle, CM_ACTIVATE, 0, 0);
      ModalResult := 0;

     // 接管線程主消息循環，使窗口“模態”化
     repeat
      Application.HandleMessage;
      if Application.FTerminate then
       ModalResult := mrCancel
      else
          if ModalResult <> 0 then CloseModal;
      until ModalResult <> 0;
      Result := ModalResult;
      SendMessage(Handle, CM_DEACTIVATE, 0, 0);
      if GetActiveWindow <> Handle then ActiveWindow := 0;
   finally
     Hide; // 窗口消失
   end;
finally
   // 省略部分代碼
end;
end;

可見，VCL中的模態窗口是通過接管線程主消息循環來實現的，只是它的退出循環條
件是 ModalResult <> 0（ModalResult初始值為 0），那么，ModalResult 的值是何時被改變
的呢？有兩種方式可以改變這個 ModalResult 的值：
一種是程序員在模態窗口中的某個事件代碼中顯式地改變 ModalResult的值。如：
ModalResult := mrOK;
另一種是設置該窗口上的某個按鈕的 ModalResult 的屬性值，當單擊該按鈕后就改變
了窗口的 ModalResult。也許有人會奇怪，按鈕屬性是如何和窗口的屬性聯系起來的呢？看
一下 TButton的 Click 方法就知道了，該方法會在每個按鈕被按下后被執行：

procedure TButton.Click;
var
Form: TCustomForm;
begin
// 獲取按鈕父窗口的TCustomForm對象
  Form := GetParentForm(Self);

·120·

VCL  庫
// 改變Form 對象的ModalResult值
  if Form <> nil then Form.ModalResult := ModalResult;
// 調用TControl.Click()，即調用OnClick事件的用戶代碼
inherited Click;
end;

按鈕被按下后，這段程序會首先得到執行，最后的那行在對 TControl.Click()的調用中， 4
才會執行 Delphi 程序員為該按鈕定義的 OnClick 事件的代碼。
4.11  小    結
查看經典的源代碼對於每個程序員的提高，都或多或少會有所助益，尤其是像 VCL 這
樣經典的但文檔尚未完善的庫。
也許讀者感覺到了，本章中 VCL 的源碼的數量比較多。但是請不要忽略那些在代碼中
插入的注釋，我個人感覺這些注釋對於學會如何去看懂 VCL源碼至關重要。讀完這一章后，
讀者對 VCL庫的幾個核心類應該有了一個大概的了解，然后以此起步，學會自己研究 VCL
源碼的方法，這才是本章最重要的目的。
我認為，VCL 的源代碼無論對於我們掌握其實現以便更好地處理問題，還是對於學習
面向對象程序的構架，都有莫大的好處。雖然在第 1 章中說過，在 Delphi 中可以忽略你所
不想知道的細節，但請不要理會錯了。
我的意思是，在實際的開發工作中，應該力求簡單性原則，忽略不必要的、繁瑣的細
節而主攻程序的靈魂——業務邏輯。而在學習的時候，應該力求深度，“知其然而又知其
所以然”。而且這時，Delphi 絕對不會阻礙你去探求其真實所在。這正是其他 RAD工具所
不具備的！
相信我，總會有意外的……

Delphi  高手突破
正如同現實生活中我們不可能事事如意，你所寫的代碼也不可能每一行都能得到正確
的執行。生活中遇到不如意的事情，處理好了，雨過天晴；處理不好，情況會越變越糟，
甚至一發而不可收拾，后果難料。程序設計中同樣如此，所謂健壯的程序，並非不出錯的
程序，而是在出錯的情況下能很好地處理的程序。
因此，錯誤處理一直是程序設計領域的一個重要課題。而異常就是面向對象編程提供
的錯誤處理解決方案。它是一個非常好的工具，如果你選擇了 OOP，選擇了 Delphi，那么
異常也就成為你的惟一選擇了。
要讓你信服地選擇異常，需要給出一些理由。在本章中會讓你清楚明白地了解異常所
帶來的好處。
3.1  異常的本質
什么是異常？為什么要用它？
在基於函數的結構中，一般使用函數返回值來標明函數是否成功執行，並給出錯誤類
型等信息。於是就會產生如下形式的代碼：

nRetVal := SomeFunctionToOpenFile();

if nRetVal = E_SUCCESSED then // 成功打開
begin
  ……
end
else if nRetVal = E_FILE_NOT_FOUND then // 沒有找到文件
begin
  ……
end
else if nRetVal = E_FILE_FORMAT_ERR then // 文件格式錯
begin
  ……
end
else then
begin
  ……
end

使用返回錯誤代碼的方法是非常普遍的，但是使用這樣的方法存在兩個問題：
（1）造成冗長、繁雜的分支結構（大量的 if 或 case 語句），使得程序流程控制變得
復雜，同時造成測試工作的復雜，因為測試需要走遍每個分支。

·50·

異常及錯誤處理
（2）可能會存在沒有被處理的錯誤（函數調用者如果不判斷返回值的話）。
異常可以很好地解決以上兩個問題。
所謂“異常”是指一個異常類的對象。Delphi 的 VCL 中，所有異常類都派生於 Exception
類。該類聲明了異常的一般行為、性質。最重要的是，它有一個 Message 屬性可以報告異
常發生的原因。
拋出一個異常即標志一個錯誤的發生。使用 raise 保留字來拋出一個異常對象，如：
3
raise Exception.Create(′An error occurred!′);
但需要強調的是，異常用來標志錯誤發生，卻並不因為錯誤發生而產生異常。產生異
常僅僅是因為遇到了 raise，在任何時候，即使沒有錯誤發生，raise 都將會導致異常的發生。注意：異常的發生，僅僅是因為 raise，而非其他！
一旦拋出異常，函數的代碼就從異常拋出處立刻返回，從而保護其下面的敏感代碼不
會得到執行。對於拋出異常的函數本身來說，通過異常從函數返回和正常從函數返回（執
行到函數末尾或遇到了 Exit）是沒有什么區別的，函數代碼同樣會從堆棧彈出，局部簡單
對象（數組、記錄等）會自動被清理、回收。
采用拋出異常以處理意外情況，則可以保證程序主流程中的所有代碼可用，而不必加
入繁雜的判斷語句。
例如，函數 A拋出異常：

function A() : Integer;
vat
  pFile : textfile;
begin
  …… // 一些代碼
  pFile := SomeFunctionToOpenAnFile();
  if pFile = nil then
raise Exception.Create(′Open file failed!′); // 文件打開失敗拋出異常
Read(pFile, ……); // 讀文件
  …… // 其他一些對文件的操作，此時可以保證文件指針有效
end;

函數 A的代碼使得對文件打開的出錯處理非常簡單。如果打開文件失敗，則拋出一個
Exception 類的異常對象，函數立刻返回，從而保護了以下對文件指針的操作不被執行。而
之后的代碼可以假設文件指針肯定有效，從而令代碼更加美觀。
生活中，我們每天扔掉的垃圾都會有清潔工人收拾、處理，否則生活環境中豈不到處
充斥着垃圾？同樣，拋出的異常也需要被捕獲和處理。假設函數 B 調用了函數 A，要捕獲
這個文件打開失敗的異常，就需要在調用 A 之前先預設一個陷阱，這個陷阱就是所謂的
“try…except 塊”。

·51·

Delphi  高手突破
先看一下函數 B 的代碼：

procedure B();
begin
  …… // 一些代碼
try
   A(); // 調用A
   SomeFunctionDependOnA(); // 依賴於A的結果的函數
Except
   ShowMessage(′some error occured′); // 嘿嘿，掉進來了，發生異常
End;
  …… // 繼續的代碼
end;

A拋出的異常，會被 B所設的 try…except 所捕獲。一旦捕獲到異常，就不再執行之后
的敏感代碼，而是立刻跳至 except 塊執行錯誤處理，處理完成后再繼續執行整個 try 塊之
后的代碼。程序流程的控制權被留在了函數 B。
如果不喜歡自己收拾垃圾，因而在 B 中並沒有預設 try…except 塊的話，則異常會被繼
續拋給 B 的調用者，而如果 B 的調用者同樣不負責任，則異常會被繼續像踢足球一樣被踢
給更上層的調用者，依此類推。不過，不用擔心，我們有一個大管家，大家都不要的燙手
山芋，它會幫我們收拾，那就是——VCL（Delphi 的應用程序框架）。
因為 VCL 的框架使得所編寫的整個應用程序被包在一個大的 try…except 中，無論什
么沒有被處理的異常，最終都會被它所捕獲，並將程序流程返回到最外層的消息循環中，
決無遺漏！這也就是為什么會看到很多用 Delphi 所編寫的但並不專業的小軟件有時會跳出
一個報告錯誤的對話框（如圖 3.1 所示）。發生這樣的情況應該責怪軟件的編寫者沒有很
好地處理錯誤，但有些不明白異常機制的程序員常常會責怪 Delphi 編寫的程序怎能會有這
樣的情況發生。其實出現這個提示，應該感謝 VCL的異常機制讓程序可以繼續運行而不是
“非法終止”。

圖3.1  異常被VCL所捕獲注意：VCL 用一個大的 try…except 將代碼包裹起來！
因此，在 VCL 框架中不會有不被處理的異常，換句話說，也就是不會有不被處理的錯
誤（雖然筆者說過異常並不等於錯誤）。對異常的捕獲也非常簡單，不見了一大堆的 if 或

·52·

異常及錯誤處理
case，程序控制流程的走向也就十分清晰明了了，這是給測試人員帶來的好消息。
3.2 創建自己的異常類
異常機制是完全融入面向對象的體系的，所以異常類和一般類一樣具有繼承和多態的
3
性質。其實，異常類和普通類並沒有什么區別。
Object Pascal的運行時異常基類是 Exception，VCL中所有異常類都應該從它派生。當
然，Object Pascal 語言並不規定如此，可以用 raise 拋出任何除簡單類型之外的類類型的對
象，try…except 同樣可以捕獲它，在異常處理后同樣會自動析構、回收它，只是 Exception
定義了異常的大多數特征。既然別人已經為我們准備了一個好用的、完備的 Exception，當
然沒有理由不用它。
也許讀者也已經注意到，所有 VCL 的異常發生時，彈出的警告對話框都帶有一段有價
值的對於異常的發生原因的描述（正如圖 3.1 中的“"is not a valid integer value”）。這段
描述對於 debug 工作是非常有用的。它正是來自於 Exception 類的 Message屬性，所有異常
類被創建時都必須給出一個出錯描述。因此，在定義、使用自己的異常類時，也要給出一
個不會令人迷惑的、明白說出錯誤原因的 Message 屬性。注意：從 Exception派生自己的異常類！
下面以一個示例程序來演示如何定義、使用自己的異常類，其代碼及可執行文件可在
配書光盤的 exception 目錄下找到。
程序運行后的界面如圖 3.2 所示。

圖3.2 自定義異常類演示程序界面
該程序的運行界面十分充分地體現了第 1 章所說的“簡單性”原則。界面上只有 3 個
按鈕，先看上面兩個（另一個“try…finally”按鈕先不說明，留待 3.3 節講解）。一個模擬
打開文件時發生“找不到文件”的錯誤，一個模擬發生“文件格式錯”的錯誤。所謂模擬
發生錯誤，就是在並沒有真正發生錯誤的情況下拋出異常，使得編譯器認為發生了錯誤，
即單擊這兩個按鈕后，程序會分別拋出相應的異常。
首先要定義兩種錯誤所對應的異常類。它們的定義和實現在 ExceptionClass.pas 單元
中。該單元代碼清單如下：

·53·

Delphi  高手突破
unit ExceptionClass;

interface

uses SysUtils, Dialogs;

Type

  EFileOpenFailed = class(Exception) // 定義一個文件打開失敗的通用異常類
public
    procedure Warning(); virtual; abstract;
end;

  EFileNotFound = class(EFileOpenFailed) // 細化文件打開失敗的異常
public
    procedure Warning(); override;
end;

  EFileFormatErr = class(EFileOpenFailed) // 細化文件打開失敗的異常
public
    procedure Warning(); override;
end;

implementation

{ EFileNotFound }

procedure EFileNotFound.Warning;
begin
ShowMessage('真是不可思議，竟然找不到文件！');
end;

{ EFileFormatErr }

procedure EFileFormatErr.Warning;
begin
ShowMessage('更不可思議的是，文件格式不對！');
end;

end.

我們先定義了一個標志打開文件失敗的異常基類 EFileOpenFailed，並給它聲明了一個

·54·

異常及錯誤處理
抽象方法 Warning。然后又細化了錯誤的原因，從而派生出兩個異常類——EFileNotFound、
EFileFormatErr，它們都具體實現了 Warning 方法。
在應用程序的主Form（Form1）中，定義一個模擬發生錯誤並拋出異常的SimulateError()
方法來模擬發生錯誤、拋出異常。
然后定義一個 ToDo()方法來調用會引發異常的 SimulateError()，並且用 Try 將其捕獲
進行異常處理。
3
最后在兩個按鈕的 OnClick()事件中，調用 ToDo()方法。
其代碼清單如下：

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
      procedure SimulateError(Button : TObject);
      procedure ToDo(Button : TObject);
  end;

var
  Form1: TForm1;

implementation

uses ExceptionClass;

·55·

Delphi  高手突破
{$R *.dfm}

procedure TForm1.SimulateError(Button : TObject);
begin
    if Button = Button1 then
        raise EFileNotFound.Create('File Not Found')
    else if Button = Button2 then
        raise EFileFormatErr.Create('File Format Error')
    else // Button = Button3
        raise Exception.Create('Unknonw Error');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    ToDo(Sender);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
    ToDo(Sender);
end;

procedure TForm1.ToDo(Button : TObject);
begin
    try
        SimulateError(Button)
    except
        on E : EFileOpenFailed do
            E.Warning();
        on E : Exception do
            ShowMessage(E.Message);
    end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
    AStream : TMemoryStream;
begin
    AStream := TMemoryStream.Create();

    try
        SimulateError(Sender);

·56·

異常及錯誤處理
    finally
        AStream.Free();
    end;
end;

end.
  3
程序運行后，當單擊界面上方的兩個按鈕之一時，都會調用 ToDo 方法。而在 ToDo
方法中，由於 SimulateError 被調用而引發一個異常，雖然並沒有真的發生打開文件錯誤，
但確實拋出了異常。這再次說明了，異常只是用來標志錯誤，而並不等同於錯誤。
程序中，我們定義了一個標志打開文件失敗的異常基類 EFileOpenFailed，以及兩個派
生的異常類——EFileNotFound、EfileFormatErr。這樣定義異常類框架，給錯誤處理部分帶
來了更多的靈活性。這是多態性給我們的又一個恩惠。可以自由選擇需要捕獲的異常的“精
度”。也就是說，如果用戶非常關心發生錯誤的具體原因，則可以捕獲每個最底層的異常
類；而如果只關心是否發生了打開文件的錯誤，那么可以只捕獲 EFileOpenFailed類；若關
心的只是是否有錯誤發生，則只需捕獲 Exception 就行了。
在 SimulateError 的調用之外，設置了 try…except，那么它所引發的異常都會被捕獲。
將“精度”更“細”的異常類的處理代碼放在前面，而把“精度”較“粗”的異常類的處
理代碼放在后面。如果相反，則所有異常都會被 Exception的處理代碼捕獲，而其他的異常
類的處理代碼則永遠都沒有機會執行了。
Exception 程序演示了一個很小的、自定義的異常類框架的定義、實現及使用。“麻雀
雖小，五臟俱全”，它給出了一種在自己程序中錯誤的捕獲、處理的思路。
3.3  try…finally
現在已經知道，在函數中引發異常將導致函數的正常返回，因此函數棧中的局部簡單
對象（數組、記錄等）會得到釋放。同時也知道了，在 Object Pascal 中所有的類對象都在
堆中被構造，編譯器不會在退出函數時自動調用它們的析構函數，那么如何保證所有的局
部類對象也能被釋放呢？
Object Pascal引入了獨特的 try...finally 來解決這個問題。
try…finally 塊幫你保證一些重要的代碼在無論是否發生異常的情況下都能被執行，這
些代碼位於 finally和 end之間。
再次打開 Exception 程序，現在來看一下沒用過的第 3 個按鈕。為它的 Click 事件添加
如下的代碼：

procedure TForm1.Button3Click(Sender: TObject);
var
  AStream : TMemoryStream;

·57·

Delphi  高手突破
begin
  AStream := TMemoryStream.Create();

try
   SimulateError(Self);
finally
   AStream.Free();
end;
end;

它首先創建了一個內存流對象，以模擬該函數申請了一些系統資源。然后還是調用
了 SimulateError 方法，不過這次 SimulateError 拋出的是一個 Exception 異常。但在此把
內存流對象的銷毀工作放在了 finally 保護之中，由此保證該對象的釋放。可以自己單步
跟蹤試一下，無論在發生異常（即調用了 SimulateError）的情況下，還是正常退出（不
調用 SimulateError 或將 SimulateError 的調用改為 Exit）的情況下，AStream.Free()都會得
到執行。
同時擁有 try…except 和 try…finally，應該說是 Delphi 程序員的一種幸運，值得慶幸。
只是，我們想得到的會更多，會希望擁有

try
  ……
except
  ……
finally

這樣的結構，只是目前還得不到滿足。雖然可以用

try
try
   ……
except
   ……
end
finally
  ……
end;

來取代，但顯然不如所希望的那樣結構美觀和優雅。這不能不說是一種遺憾，讓我們寄希
望於下一個 Delphi 版本吧！

·58·

異常及錯誤處理
3.4  構造函數與異常
這個話題在 C++社區中經常會被提起，而在 Delphi 社區中似乎從來沒有人注意過，也
許由於語言的特性而使得 Delphi 程序員不必關心這個問題。但我想，Delphi 程序員也應該
3
對該問題有所了解，知道語言為我們提供了什么而使得我們如此輕松，不必理會它。正所
謂“身在福中須知福”。
我們知道，類的構造函數是沒有返回值的，因此如果構造函數構造對象失敗，則不可
能依靠返回錯誤代碼來解決。那么，在程序中如何標識構造函數的失敗呢？最“標准”的
方法就是：拋出一個異常。
構造函數失敗，意味着對象的構造失敗。那么拋出異常之后，這個“半死不活”的對
象會被如何處理呢？
在此，讀者有必要先對 C++對這種情況的處理方式有一個了解。
在 C++中，構造函數拋出異常后，析構函數不會被調用。這種做法是合理的，因為此
時對象並沒有被完整構造。
如果構造函數已經做了一些諸如分配內存、打開文件等操作，那么 C++類需要有自己
的成員來記住做過哪些動作。當然，這樣做對於類的實現者來說非常麻煩。因此，一般 C++
類的實現者都避免在構造函數中拋出異常（可以提供一個諸如 Init 和 UnInit 的成員函數，
由構造函數或類的客戶去調用它們，以處理初始化失敗的情況）。而每一本 C++的經典著
作所提供的方案都是使用智能指針（STL 的標准類 auto_ptr）。
在 Object Pascal 中，這個問題變得非常簡單，程序員不必為此大費周折。如果 Object
Pascal 的類在構造函數中拋出異常，則編譯器會自動調用類的析構函數（由於析構函數不
允許被重載，可以保證只有惟一一個析構函數，因此編譯器不會迷惑於多個析構函數之中）。
析構函數中一般會析構成員對象，而 Free()方法保證了不會對 nil 對象（即尚未被創建的成
員對象）調用析構函數，因此在使得代碼簡潔優美的前提下，又保證了安全。
以下的程序演示了構造函數中拋出異常后，Object Pascal 編譯器所作的處理方法。
首先定義 TMyClass：

type
  TMyClass = class
private
    FStr : PChar; // 字符串指針
public
   constructor Create();
    destructor Destroy(); override;
end;

然后實現 TMyClass，並讓它的構造函數中拋出異常：

·59·

Delphi  高手突破
constructor TMyClass.Create();
begin
  FStr := StrAlloc(10); // 構造函數中為字符串指針分配內存
StrCopy(FStr, 'ABCDEFGHI');
  raise Exception.Create('error'); // 拋出異常，沒有理由
end;

destructor TMyClass.Destroy();
begin
StrDispose(FStr); // 析構函數中釋放內存
WriteLn('Free Resource');
end;

最后，編寫程序主流程的代碼。主流程中首先創建 TMyClass 類的實例：

var
  Obj : TMyClass;
  i : integer;
begin
try
    Obj := TMyClass.Create();
    // Obj.Free(); // 不調用析構函數，但發生異常時，編譯器自動調用了析構函數
   WriteLn('Succeeded');
except
    Obj := nil;
   WriteLn('Failed');
end;

Read(i); // 暫停屏幕，以便觀察運行結果
end.

這段代碼中，創建 TMyClass 類的實例時遇到了麻煩，因為 TMyClass 的構造函數拋出
了異常，但這段代碼執行結果卻是：

Free Resource
Failed

出現了“Free Resource”，說明發生異常后，析構函數被調用了。而這正是在構造函
數拋出異常之后，編譯器自動調用析構函數的結果。
因此，如果類的說明文檔或類的作者告知你，類的構造函數可能會拋出異常，那就要
記得用 try…except 包住它！

·60·

異常及錯誤處理
C++與 Object Pascal 對於構造函數拋出異常后的不同處理方式，其實正是兩種語言的
設計思想的體現。C++秉承 C 語言的風格，注重效率，一切交給程序員來掌握，編譯器不
做多余動作；Object Pascal 繼承 Pascal 的風格，注重程序的美學意義，編譯器幫助程序員
完成復雜的工作。
3.5 小結 3
異常是面向對象編程帶來的非常好的工具，不加以利用是很可惜的。但是，正如萬事
都有個“度”，濫用異常也是不可取的。使用異常不是沒有代價，它會增加程序的負擔，
編寫若干 try...except 和編寫數

別人造磚我砌房！

免責聲明！

本站轉載的文章為個人學習借鑒使用，本站對版權不負任何法律責任。如果侵犯了您的隱私權益，請聯系本站郵箱yoyou2525@163.com刪除。

猜您在找 delphi高手突破之異常及錯誤處理 delphi簡單的分頁實現（高手可以不看） delphi助手類為什么要看源碼、如何看源碼，高手進階必看攻防世界WEB高手進階之blgdel 攻防世界web高手進階之blgdel 攻防世界WEB高手進階之Zhuanxv Delphi 進階基礎技能說明向高手進階，從 0 開始手寫實現一個 RPC 框架！ Mysql高手系列 - 第24篇：如何正確的使用索引？【高手進階】