The real fun (if we can say so) is when you spend time to do useless things, otherwise writing programs can be considered as a work. Although there is some effort involved, you can really have a lot of fun in Delphi.
This paper describes a number of ways to loose time and have fun in Delphi, writing components, stretching Delphi and Windows to the limit, and configuring the environment with Experts and other tools. Being a "fun" presentation, some multimedia will be involved, of course.
We want to built a component, but how do we build one? Please refer to a specific session, article, or book, to discover everything about writing components. For this presentation you only need to know that a component is a subclass of class TComponent (or one of its subclasses), that there are three kinds of components (non-visual components, window-based components, and graphical components), and that components have methods, properties, and events.
Instead of discussing components in general, I prefer showing you how to build some useless ones (in this section) and some very strange ones (in the next section). For the moment, let me focus on how you can make a lot of work to obtain very little, but still have some fun in the process (and in the result).
Still, we have to write some code. In fact if we want our component to have standard properties and events we have to list them:
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;
We also need to write the code of the Create constructor of the component (which sets the default values) and the Register procedure:
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;
I've actually written two versions of theis component. The simplest version redefines a Windows message, with the following code, in which the mouse move message handler looks for and eventually calls the OnClick event handler:
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;
The second version has much more code, since I try to repeat the mouse
OnClick event when the user moves the mouse over the button or after a
given amount of time. Here is the declaration of the class:
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;
The code is quite complex, and we don't have time to cover the details. Basically when a user moves the mouse over the area of the button (WmMouseMove) the component starts a timer or counts the move messages. After a given amount of time, or when the proper number of move messages has been reached, the component simulates the mouse click event. The plain OnClick events do not work properly, but I decided I don't care...
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;
If you really want to get rid of edit boxes, here comes the solution: a label input components, a label component that can get the user input. This is an overly complex component, because labels have no way to get the input from the keyboard. They are graphical components, not based on a window, so they cannot receive the input focus, and they cannot get text. For this reason I've developed this example in two steps.
First step is an input-button component (quite simple) to show you the input code:
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;
The input label, instead, has to do a number of tricks to bypass the
problems related to its internal structure. Basically the problem can be solved
by creating other hidden components (why not an edit box?) at runtime. Here
is the declaration of the class:
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;
When the label is created it generates the edit box, and set some event handler for it. In fact as the user clicks on the label the focus is moved to the (invisible) edit box, and we use its events to update the label. Notice in particular the code used to mimic the focus for the label, which is based on the DrawFocusRect API call:
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;
The sound button component has two brand new properties:
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;
These sounds are played when a button is pressed or realeased:
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;
To provide the images to the animated button, I've decide to rely on the ImageList component, which allows you to place many bitmaps in a single container. Each of the bitmaps will be displayed after the previous one, providing animated effects. The code is quite long, and is available for reference in the companion source code, but it is not in the paper.
This is the class definition:
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;
The only relevant method of the class is the OnTimer event handler, which includes the font changing code:
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 [I] is TWinControl then
SendMessage (
TWinControl (Owner.Components [I]).Handle,
wm_SetFont, Fnt.Handle, MakeLong (1,0));
end;
Fnt.Free;
end;
end;
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;
Again the most relevant portion of the code is in the OnTimer event handler:
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;
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;
type
TSpecialIntProperty = class (TIntegerProperty)
public
function GetAttributes: TPropertyAttributes;
override;
procedure Edit; override;
end;
The important method is Edit, which is often used to show a dialog box (built
in Delphi, as usual):
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;
In this code GetValue and SetValue are two special methods of the parent
property editor, accessing to the data of the given property of the current
component. To make this work you have to write also a proper registration procedure:
procedure Register;
begin
RegisterPropertyEditor (TypeInfo(Integer),
TButton, '', TSpecialIntProperty);
end;
RegisterPropertyEditor (TypeInfo(string),
TSoundButton, 'SoundUp', TSoundProperty);
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.
This is actually an excuse to see how an expert is built. First derive a new class, with a bunch of overridden methods (required since they are virtual abstract):
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;
Most of the methods have empty or default code. The only real code is in the
Execute method:
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;
The code of this example is fairly simple: Just write several for loops in which you allocate resources forever. Here are two methods:
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', [I]);
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', [I]);
Application.ProcessMessages;
end;
finally
ButtonPens.Caption := Format ('Created: %d', [I]);
end;
end;
This last trick is explored by the UAE example. You can show a simple UAE message box, build a full fledged dialog box, with the details sub window, and even make a close button which doesn't want to be pressed.
The fake error form has a details button that shows open the second part of the form. This is accomplished by adding components out of the surface of the form itself, as you can see in its textual description:
object Form2: TForm2
AutoScroll = False
Caption = 'Error'
ClientHeight = 93
ClientWidth = 320
OnShow = FormShow
object Label1: TLabel
Left = 56
Top = 16
Width = 172
Height = 65
AutoSize = False
Caption =
'The program has performed an illegal ' +
'operation. If the problem' +
'persist contact the software vendor.'
WordWrap = True
end
object Image1: TImage
Left = 8
Top = 16
Width = 41
Height = 41
Picture.Data = {...}
end
object Button1: TButton
Left = 240
Top = 16
Width = 75
Height = 25
Caption = 'Close'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 240
Top = 56
Width = 75
Height = 25
Caption = 'Details >>'
TabOrder = 1
OnClick = Button2Click
end
object Memo1: TMemo // out of the form!
Left = 24
Top = 104
Width = 265
Height = 89
Color = clBtnFace
Lines.Strings = (
'AX:BX 73A5:495B'
'SX:PK 676F:FFFF'
'OH:OH 7645:2347'
'Crash 3485:9874'
''
'What'#39's going on here?')
TabOrder = 2
end
end
When a user presses the details button the program simply update the size of the form:
procedure TForm2.Button2Click(Sender: TObject); begin Height := 231; end;A second form, which inherits from the first one, has an extra trick, a moving close button:
procedure TForm3.Button1Click(Sender: TObject); begin Button1.Left := Random (ClientWidth - Button1.Width); Button1.Top := Random (ClientHeight - Button1.Height); end;Finally, you can create a hole in a window by using the SetWindowRgn Win32 API function. This can really make users scream:
procedure TForm1.Button4Click(Sender: TObject);
var
HRegion1, Hreg2, Hreg3: THandle;
Col: TColor;
begin
ShowMessage ('Ready for a real crash?');
Col := Color;
Color := clRed;
PlaySound ('boom.wav', 0, snd_sync);
HRegion1 := CreatePolygonRgn (Pts,
sizeof (Pts) div 8,
alternate);
SetWindowRgn (
Handle, HRegion1, True);
ShowMessage ('Now, what have you done?');
Color := Col;
ShowMessage ('You should better buy a new monitor');
end;