B
Bahl
Unregistered / Unconfirmed
GUEST, unregistred user!
[h1]Delphi有趣的一面[/h1]
Delphi编程很有趣。它的开发环境易于使用，功能强大，程序员都爱使用它。你用Delphi的时间越长，你就会发现你有越来越多的方法去配置它，让它做出一些前所未知的行为。除了写程序以外你还可以用组件与专家去扩展它自己的开发环境。真正的乐趣产生于你把时间花在一些“没用“的事情上时。尽管这需要一些相关的努力，但你能体会到Delphi的许多乐趣。
这篇文章描述了用Delphi打发时间，获取乐趣的许多方法，如写组件，最大限度地扩展Delphi与Windows的功能，用专家与其他工具来配置开发环境。做为一篇
”乐趣“的介绍，它理所当然地也要涉及一些多媒体的内容。
[h1]无用的组件 [/h1] 如果你用Delphi编程，你也许知道Smiley。它是最早开发出来的组件之一，用来显示一张笑脸。实际上，它是一个演示如何建立组件的很好的工具。
我们想建立一个组件，可是我们该怎么做呢？请参考一下相关的文章与书籍来获取建立组件的必要知识。在这篇文章里你只需要知道一个组件实际上是TComponent 的一个子类，有三种不同类型的组件（非可视化组件，基于Windows的组件，图形组件），组件有方法，属性与事件就行了。
我将向你演示如何建立一些无用的组件（这一小节）与一些很奇特的组件（下一小节），而不是从总体上讨论组件。现在，让我们把注意力集中于如何建立一个无用的组件。尽管这是一件事倍功半的工作，但你仍能从中获得一些乐趣。
[h2]什么也不做的组件[/h2] 第一个组件也许是你能建立的最无用的组件，它什么也不做。幸运的是我们只需要写一点点代码来实现它。这个什么也不做的组件是一个图形组件，没有输出，仅有继承的属性与事件。我看不出它有什么用处。
但我们仍要写一点代码。如果我们要我们的组件有标准的属性与事件的话，我们就必须将它们列出来：
type
TNothing = class(TGraphicControl)
public
constructor Create (Owner: TComponent);
override;
published
property Width default 50;
property Height default 50;
property Align;
property ShowHint;
property Visible;
...
end;
我们还要为这个组件的Create构造函数与注册过程写代码。
constructor TNothing.Create (Owner: TComponent);
begin
// call parent class constructor first
inherited Create (Owner);
// set the size
Width := 50;
Height := 50;
end;
procedure Register;
begin
RegisterComponents('DDHB', [TNothing]);
end;
[h2] 自动按下的按钮[/h2] 这个组件是专门供那些懒惰的用户使用的，你不需要点击它来触发OnClick事件，你只要把鼠标拖动到它上面就行了。按照最能浪费时间的惯例，这个组件需要大量工作，因为我们必须对鼠标进行处理，捕捉它，还要完成一些其他的任务。它虽然需要大量工作，但是很值。
这个组件有两个不同版本。最简单的版本用下面的代码重新定义了一个Windows消息，鼠标移动消息出来器不停地寻找与调用 OnClick 事件出来器：
type
TAutoButton1 = class(TButton)
private
procedure WmMouseMove (var Msg: TMessage);
message wm_MouseMove;
end;
procedure TAutoButton1.WmMouseMove (var Msg: TMessage);
begin
inherited;
if Assigned (OnClick) then
OnClick (self);
end;
第二个版本的代码则多的多。因为我试图在用户把鼠标移动至按钮上或给定的时间已过时重复鼠标OnClick事件。这里是类的声明：
type
TAutoKind = (akTime, akMovement, akBoth);
TAutoButton2 = class(TButton)
private
FAutoKind: TAutoKind;
FMovements: Integer;
FSeconds: Integer;
// really private
CurrMov: Integer;
Capture: Boolean;
MyTimer: TTimer;
procedure EndCapture;
// message handlers
procedure WmMouseMove (var Msg: TWMMouse);
message wm_MouseMove;
procedure TimerProc (Sender: TObject);
procedure WmLBUttonDown (var Msg: TMessage);
message wm_LBUttonDown;
procedure WmLButtonUp (var Msg: TMessage);
message wm_LButtonUp;
public
constructor Create (AOwner: TComponent);
override;
published
property AutoKind: TAutoKind
read FAutoKind write FAutoKind default akTime;
property Movements: Integer
read FMovements write FMovements default 5;
property Seconds: Integer
read FSeconds write FSeconds default 10;
end;
代码相当复杂。我们没有时间去详细地解释它。简单地说，当用户把鼠标移动到按钮区域上时，这个组件开始一个定时器或给移动消息计数。在给定的时间已过或移动消息已达到一定数目时，这个组件触发鼠标单击事件。OnClick 事件的代码很简单，它工作的也不太好，不过我不会在意的。
procedure TAutoButton2.WmMouseMove (var Msg: TWMMouse);
begin
inherited;
if not Capture then
begin
SetCapture (Handle);
Capture := True;
CurrMov := 0;
if FAutoKind <> akMovement then
begin
MyTimer := TTimer.Create (Parent);
if FSeconds <> 0 then
MyTimer.Interval := 3000
else
MyTimer.Interval := FSeconds * 1000;
MyTimer.OnTimer := TimerProc;
MyTimer.Enabled := True;
end;
end
else
// capture
begin
if (Msg.XPos > 0) and (Msg.XPos < Width)
and (Msg.YPos > 0) and (Msg.YPos < Height) then
begin
// if we have to consider movement...
if FAutoKind <> akTime then
begin
Inc (CurrMov);
if CurrMov >= FMovements then
begin
if Assigned (OnClick) then
OnClick (self);
EndCapture;
end;
end;
end
else
// out of the area... stop!
EndCapture;
end;
end;
procedure TAutoButton2.EndCapture;
begin
Capture := False;
ReleaseCapture;
if Assigned (MyTimer) then
begin
MyTimer.Enabled := False;
MyTimer.Free;
MyTimer := nil;
end;
end;
procedure TAutoButton2.TimerProc (Sender: TObject);
begin
if Assigned (OnClick) then
OnClick (self);
EndCapture;
end;
procedure TAutoButton2.WmLBUttonDown (var Msg: TMessage);
begin
if not Capture then
inherited;
end;
procedure TAutoButton2.WmLButtonUp (var Msg: TMessage);
begin
if not Capture then
inherited;
end;
[h2]输入标签组件[/h2] 许多Delphi程序员问我怎样让用户在标签中输入文本，我常常回答：“用编辑框来替代”。
如果你确实不想用编辑框，这里有解决办法：标签输入组件。这是一个非常复杂的组件，因为标签无法从键盘获得输入。它是图形组件，并不是基于窗口的，所以不能接收输入焦点，也不能获取文本。为此，我分两步来完成这个组件。
第一步是建立一个输入按钮组件来向你演示输入代码。
type
TInputButton = class(TButton)
private
procedure WmChar (var Msg: TWMChar);
message wm_Char;
end;
procedure TInputButton.WmChar (var Msg: TWMChar);
var
Temp: String;
begin
if Char (Msg.CharCode) = #8 then
begin
Temp := Caption;
Delete (Temp, Length (Temp), 1);
Caption := Temp;
end
else
Caption := Caption + Char (Msg.CharCode);
end;
输入标签组件得用上许多窍门来绕过它的内部结构所带来的问题。这个问题可以由在运行时建立另一个隐藏的组件来解决。这里是类的声明：
type
TInputLabel = class (TLabel)
private
MyEdit: TEdit;
procedure WMLButtonDown (var Msg: TMessage);
message wm_LButtonDown;
protected
procedure EditChange (Sender: TObject);
procedure EditExit (Sender: TObject);
public
constructor Create (AOwner: TComponent);
override;
end;
当标签被创建时它生成了一个编辑框并为它设置了一些事件处理器。事实上，当用户点击标签时焦点被移动到了编辑框上。我们利用它的事件来更新标签。
constructor TInputLabel.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
MyEdit := TEdit.Create (AOwner);
MyEdit.Parent := AOwner as TForm;
MyEdit.Width := 0;
MyEdit.Height := 0;
MyEdit.TabStop := False;
MyEdit.OnChange := EditChange;
MyEdit.OnExit := EditExit;
end;
procedure TInputLabel.WMLButtonDown (var Msg: TMessage);
begin
MyEdit.SetFocus;
MyEdit.Text := Caption;
(Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;
procedure TInputLabel.EditChange (Sender: TObject);
begin
Caption := MyEdit.Text;
Invalidate;
Update;
(Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;
procedure TInputLabel.EditExit (Sender: TObject);
begin
(Owner as TForm).Invalidate;
end;
[h2]带声音的按钮[/h2] 当你按下一个按钮时你能看见按钮按下时的三维效果。为什么不家上第四维——声音呢？
这个带声音的按钮有两个全新的属性：
type
TDdhSoundButton = class(TButton)
private
FSoundUp, FSoundDown: string;
protected
procedure MouseDown(Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
override;
procedure MouseUp(Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
override;
published
property SoundUp: string
read FSoundUp write FSoundUp;
property SoundDown: string
read FSoundDown write FSoundDown;
end;
当按钮被按下或释放时就会发出声音：
procedure TDdhSoundButton.MouseDown(
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
begin
inherited;
PlaySound (PChar (FSoundDown), 0, snd_Async);
end;
procedure TDdhSoundButton.MouseUp(Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
begin
inherited;
PlaySound (PChar (FSoundUp), 0, snd_Async);
end;
[h1] 奇异的组件[/h1] 在介绍完第一组“无用”的组件之后，我们开始介绍第二组，它包括一些相当难使用的组件。在专业程序中使用它们是毫无意义的，不过它们很有趣。
[h2]自动调整字体的组件[/h2] 程序员很可能在一个窗体中使用多种字体，让它看起来很花哨。但是没有东西能与一个能在运行时自动调整窗体上的字体的组件相比。这个TAutoFont组件甚至提供了两种不同的方法：它既能使用随机字体，也允许对程序作更多的控制。
这里是类定义：
type
TAutoFont = class(TComponent)
private
FTimer: TTimer;
FInterval: Cardinal;
FFixedSize, FAllAlike: Boolean;
protected
procedure OnTimer (Sender: TObject);
procedure SetInterval (Value: Cardinal);
public
constructor Create (AOwner: TComponent);
override;
published
property Interval: Cardinal
read FInterval write SetInterval default 10000;
property FixedSize: Boolean
read FFixedSize write FFixedSize default True;
property AllAlike: Boolean
read FAllAlike write FAllAlike default True;
end;
OnTimer事件处理器包括了字体调整代码：
procedure TAutoFont.OnTimer (Sender: TObject);
var
I: Integer;
Fnt: TFont;
begin
(Owner as TForm).Font.Name :=
Screen.Fonts [Random (Screen.Fonts.Count)];
if not FFixedSize then
(Owner as TForm).Font.Size := Random (36);
if not FAllAlike then
begin
Fnt := TFont.Create;
Fnt.Assign ((Owner as TForm).Font);
for I := 0 to Owner.ComponentCount - 1 do
begin
Fnt.Name :=
Screen.Fonts [Random (Screen.Fonts.Count)];
if Owner.Components is TWinControl then
SendMessage (
TWinControl (Owner.Components ).Handle,
wm_SetFont, Fnt.Handle, MakeLong (1,0));
end;
Fnt.Free;
end;
end;
[h2]小巧的关闭窗体组件[/h2] 当你关闭一个窗体时，它只是消失了。除了隐藏窗体之外，还有很多方法去关闭它们。我并不想讨论 OnClose 事件的 Action 属性，只是向你展示一下如何通过将窗体缩小到最小尺寸来慢慢地关闭窗体的按钮。
type
TSmartClose = class(TComponent)
public
procedure Close;
end;
procedure TSmartClose.Close;
begin
(Owner as TForm).AutoScroll := False;
repeat
(Owner as TForm).ScaleBy (93, 100);
Application.ProcessMessages;
until (Owner As TForm).Height < 50;
(Owner as TForm).Close;
end;
[h2]屏幕病毒组件[/h2] 没见过屏幕病毒？它是计算机屏幕的一种症状，能在屏幕上产生红色斑点。这个病毒能攻击窗体和窗口。编写与使用它是一项非常有趣的工作。唯一的问题在于如何防止病毒扩散到窗体之外。代码怎么写？关键在与使用 GetWindowDC 建立设备上下文，然后在屏幕上绘画。
type
TScreenVirus = class(TComponent)
private
FTimer: TTimer;
FInterval: Cardinal;
FColor: TColor;
FRadius: Integer;
protected
procedure OnTimer (Sender: TObject);
procedure SetInterval (Value: Cardinal);
public
constructor Create (AOwner: TComponent);
override;
procedure StartInfection;
published
property Interval: Cardinal
read FInterval write SetInterval;
property Color: TColor
read FColor write FColor default clRed;
property Radius: Integer
read FRadius write FRadius default 10;
end;
constructor TScreenVirus.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
FTimer := TTimer.Create (Owner);
FInterval := FTimer.Interval;
FTimer.Enabled := False;
FTimer.OnTimer := OnTimer;
FColor := clRed;
FRadius := 10;
end;
procedure TScreenVirus.StartInfection;
begin
if Assigned (FTimer) then
FTimer.Enabled := True;
end;
procedure TScreenVirus.SetInterval (Value: Cardinal);
begin
if Value <> FInterval then
begin
FInterval := Value;
FTimer.Interval := Interval;
end;
end;
procedure TScreenVirus.OnTimer (Sender: TObject);
var
hdcDesk: THandle;
Brush: TBrush;
X, Y: Integer;
begin
hdcDesk := GetWindowDC (GetDesktopWindow);
Brush := TBrush.Create;
Brush.Color := FColor;
SelectObject (hdcDesk, Brush.Handle);
X := Random (Screen.Width);
Y := Random (Screen.Height);
Ellipse (hdcDesk, X - FRadius, Y - FRadius,
X + FRadius, Y + FRadius);
ReleaseDC (hdcDesk, GetDesktopWindow);
Brush.Free;
end;
[h1] 销售组件[/h1] 程序员对市场营销往往不太在行，（译者：哈哈！我是学市场营销的！）我在这里也不想给出什么实质性的建议。我注意到两种不好的倾向：一种是把版权标记放得到处都是；另一种则是处处放置使用户觉得讨厌的信息，这在 demo/trial 版中尤为常见。
版权
给一个组件加入版权信息有很多种方法。这里是一些你可以实现的特性清单：
1 把信息加入到本地菜单。
2 在一个特殊的屏幕上显示信息。
3 加入一个特殊的属性。
4 使用组件名称或标题。
5 使用一个版权组件。
6 使用窗体标题。
7 使用Delphi自己的标题。
[h2] 一个实际的例子[/h2] 在阐明了加入版权信息的意见之后，我写了一个组件来演示一下我们在实际上如何实现这些特性。TFunCopyright组件实现了：你不能更改的属性，显示令人烦恼的信息，改变窗体的标题，在一个外部组件——标签中显示版权信息。
type
TFunCopyright = class(TComponent)
private
FCopyright, FAuthor: string;
FDummy1, FDummy2: string;
FLabel: TLabel;
protected
procedure SetLabel (Value: TLabel);
public
constructor Create (AOwner: TComponent);
override;
published
property Copyright: string
read FCopyright write FDummy1;
property Author: string
read FAuthor write FDummy2;
property OutputLabel: TLabel
read FLabel write SetLabel;
end;
constructor TFunCopyright.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
FAuthor := 'Marco Cant?;
FCopyright := '(c)MC 1997';
if csDesigning in ComponentState then
begin
with Owner as TForm do
Caption := Caption +
' using a component by ' + FAuthor;
with Application do
Title := Title +
' using a component by ' + FAuthor;
ShowMessage ('This form is using a component by ' +
FAuthor);
end
else
ShowMessage ('This program uses a component by ' +
FAuthor);
end;
procedure TFunCopyright.SetLabel (Value: TLabel);
begin
if Value <> FLabel then
begin
FLabel := Value;
FLabel.Caption := FCopyright;
end;
end;
[h1]配置 Object Inspector[/h1]
在写了许多无用或疯狂的组件之后，我们可以换个话题。写一些相当复杂而不实用的属性编辑器，来自定义 Object Inspector。
[h2] 一个整型的Spin-Editor[/h2] 先从一个已存的属性编辑器类派生出一个类，再覆盖一些虚拟方法。
type
TSpecialIntProperty = class (TIntegerProperty)
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit;
override;
end;
重要的属性是Edit，它经常用来显示一个对话框。
function TSpecialIntProperty.GetAttributes:
TPropertyAttributes;
begin
Result := [paDialog, paReadOnly];
end;
procedure TSpecialIntProperty.Edit;
var
PEForm: TSpinForm;
begin
PEForm := TSpinForm.Create (Application);
try
PEForm.Edit1.Text := GetValue;
if PEForm.ShowModal = mrOK then
SetValue (PEForm.Edit1.Text);
finally
PEForm.Free;
end;
end;
在这段代码中GetValue 与SetValue是父属性编辑器的两个特殊方法，用来访问当前组件的给定属性的数据。要让它运作起来你还要写一个注册过程。
procedure Register;
begin
RegisterPropertyEditor (TypeInfo(Integer),
TButton, '', TSpecialIntProperty);
end;
[h2] 一个颜色定制属性编辑器[/h2] 这个第三方的属性编辑器会在你每次使用它时自动改变颜色。下面是全部代码。
type
TMyColorProperty = class (TColorProperty)
public
procedure Edit;
override;
end;
procedure Register;
implementation
var
nEditor: Integer;
procedure TMyColorProperty.Edit;
begin
try
case nEditor of
0: begin
FormColor1 := TFormColor1.Create (Application);
...
1: begin
FormColor2 := TFormColor2.Create (Application);
...
2: inherited Edit;
end;
finally
nEditor := (nEditor + 1) mod 3;
end;
end;
procedure Register;
begin
RegisterPropertyEditor (TypeInfo(TColor),
TComponent, '', TMyColorProperty);
end;
initialization
nEditor := 0;
end.
[h1]两个专家[/h1] 建立组件是很容易的，但其他的Delphi工具就需要更多的工作了，但是这仍然很有趣。我建立了两个专家。来演示一下它的制作。
空白的专家向导
当你开始一个新工程时，专家向导会生成一个空白窗体。这个空白的专家向导也允许你做同样的事，但是它生成一个不带窗体的工程。
首先派生出一个新类。
type
TBlankExpert = class (TIExpert)
public
function GetStyle: TExpertStyle;
override;
function GetName: string;
override;
function GetComment: string;
override;
function GetGlyph: HBITMAP;
override;
function GetState: TExpertState;
override;
function GetIDString: string;
override;
function GetMenuText: string;
override;
procedure Execute;
override;
end;
绝大部分方法只有空的或默认的代码，真正的代码在 Execute 方法中。
function TBlankExpert.GetStyle: TExpertStyle;
begin
Result := esStandard;
end;
function TBlankExpert.GetName: String;
begin
Result := 'Blank Expert'
end;
function TBlankExpert.GetComment: String;
begin
Result := '';
// no thanks
end;
function TBlankExpert.GetGlyph: HBITMAP;
begin
Result := 0;
// no thanks
end;
function TBlankExpert.GetState: TExpertState;
begin
Result := [esEnabled];
end;
function TBlankExpert.GetIDString: String;
begin
Result := 'MarcoCantu.BlankExpert'
end;
function TBlankExpert.GetMenuText: String;
begin
Result := '&Blank Expert...'
end;
procedure TBlankExpert.Execute;
var
DirName: string;
begin
if MessageDlg ('Are you sure you want to exit'#13 +
'from the current project, saving it?',
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
begin
ToolServices.SaveProject;
ToolServices.CloseProject;
SelectDirectory (DirName,
[sdAllowCreate, sdPerformCreate, sdPrompt], 0);
ToolServices.OpenProject (DirName + '/Project1.dpr');
end;
end;
[h1]Windows 95的乐趣[/h1]
[h2]使Windows当机[/h2]
怎样做到这一点？这里是一个方法清单：建立过多的窗体，建立过多的组件，使用过多的内存，耗费过多的资源，访问空指针使堆栈溢出等等。
代码是相当简单的，这里是两个方法：
procedure TForm1.ButtonWindowsClick(Sender: TObject);
var
NewForm: TForm;
Hwnd: THandle;
I: Integer;
begin
NewForm := TForm.Create (Application);
NewForm.Show;
NewForm.Update;
// create a number of windows...
try
for I := 1 to 1000000 do
begin
Hwnd := CreateWindow ('button', 'Button',
ws_child or ws_border or bs_pushbutton,
I mod (ClientWidth - 40),
I mod (ClientHeight - 20),
40, 20,
Handle, 0, HInstance, nil);
if Hwnd = 0 then
raise Exception.Create ('Out of handles');
if (I mod 20) = 0 then
NewForm.Caption := 'Created: ' +
IntToStr (I);
Application.ProcessMessages;
end;
finally
ButtonWindows.Caption := Format ('Created: %d', );
NewForm.Free;
end;
end;
procedure TForm1.ButtonPensClick(Sender: TObject);
var
H: THandle;
I: Integer;
begin
try
for I := 1 to 1000000 do
begin
H := CreatePen (ps_solid, 1, RGB (0, 0, 0));
if H = 0 then
raise Exception.Create ('Out of handles');
if (I mod 20) = 0 then
ButtonPens.Caption := Format ('Created: %d', );
Application.ProcessMessages;
end;
finally
ButtonPens.Caption := Format ('Created: %d', );
end;
end;
[h1]结论[/h1]
Windows编程的乐趣很多，我无法在一篇文章中全部介绍它们。但请你记住，我们可以通过很多方法，比如说写没什么用的应用程序或组件啦，创建其他的工具啦来获得Delphi编程的乐趣。从中你不仅可以获取金钱，更能获得乐趣。
]