Delphi高手突破(四) Delphi高级进阶

首页 > 代码库 > Delphi高手突破(四) Delphi高级进阶

Delphi高手突破(四) Delphi高级进阶

2024-08-16 06:26:27 212人阅读

别人造砖我砌房！

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 onm ouseDown: TMouseEvent read FOnMouseDown write
     FOnMouseDown;
   ……
end;

这段代码是 TControl 组件类的声明。如果你从没有接触过类似的 VCL 组件代码的代
码，不明白那些 property、read、write 的意思，那么可以先跳转到 5.1 节阅读一下相关的基
础知识，然后再回过头来到此处继续。
TControl 声明了一个 onm ouseDown属性，该属性读写一个称为 FOnMouseDown 的事
件指针。因此，FOnMouseDown 会指向 onm ouseDown 事件的用户代码。
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 派生的类都可以拥有 onm ouseDown 事件，只不过该事件属性在
TControl 中被定义成 protected，只有其派生类可见，并且在派生类中可以自由选择是否公
布这个属性。要公布该属性只需要简单地将其声明为 published 即可。如：

TMyControl = class(TControl)
published
property onm ouseDown;
end;

这些函数过程的调用关系如图 4.3 所示。
DispDispatchatch(WM(WM__LLBBUTUTTTONDONDOWN); OWN);
WMMouseDown()
DoMouseDown()
MouseDown()
程序员的 onm ouseDown 事件代码

图4.3 WM_LBUTTONDOWN消息到OnMouseDown 事件的转换过程
在此，只是以 onm ouseDown 事件为例。其实，VCL 对 Windows 各个消息的封装大同
小异，以此一例足以说明事件模型的原理。
另外，值得注意的是，在上例中的 MouseDown()函数是一个 dynamic 方法，因此可以
通过在 TControl 派生类中覆盖 MouseDown()来处理自己所编写组件的鼠标按下事件，然后
通过
inherited;
语句调用 TControl 的 MouseDown()来执行使用组件的程序员所编写的 onm ouseDown的代
码。具体内容会在第 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 =http://www.mamicode.com/
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 = http://www.mamicode.com/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 = http://www.mamicode.com/(
    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 和编写数

别人造砖我砌房！

Delphi高手突破(四) Delphi高级进阶

声明：以上内容来自用户投稿及互联网公开渠道收集整理发布，本网站不拥有所有权，未作人工编辑处理，也不承担相关法律责任，若内容有误或涉及侵权可进行投诉：投诉/举报工作人员会在5个工作日内联系你，一经查实，本站将立刻删除涉嫌侵权内容。

联系
我们

首页 > 代码库 > Delphi高手突破(四) Delphi高级进阶

Delphi高手突破(四) Delphi高级进阶

看完仍有疑问？有类似问题直接问程序猿