"David S. Becker" <dsb@plaza.ds.adp.com>
I've written a very simple unit, and devised some simple methods, to help prevent the usage of stale pointers. My biggest recommendation is to add an 'initialization' section to ALL UNITS WHICH CONTAIN POINTER OR OBJECT VARIABLES and set all the pointers (object variables are really pointers too) to nil. This will ensure that the pointers are all nilified before they are ever used. Then, simply reset pointers to nil after freeing them. My unit contains a Nilify() function for setting pointers to nil, as well as special versions of Free, Dispose, and FreeMem (called NilXXX) which test for nil before freeing memory, and resets the pointer to nil once it has been freed. I've also included a special version of Assigned(), called IsNil(), which takes a const parameter instead of a var parameter, which means you can use it on properties, etc.This unit, of course, does nothing to the VCL, so you can still get stale pointers back from the VCL... But strict adherence to the functions in this unit should help ensure YOU don't make a mistake. The only condition on its use/distribution is that you forward any changes or suggestions you might have to me. Use it and program in good health!
unit Pointers;
{
Author: David S. Becker (dsb@plaza.ds.adp.com)
Date: 1/27/97
Copyright: None
Distribution Rights: Free, unlimited use, provided you forward any and all
changes or suggestions you have to me.
This unit was created to aid in the managment of pointers and objects. Since
the compiler does not initialize pointers or objects to nil, and does not set
them to nil when freed, it is possible to accidentally reference stale
pointers. For this reason, I recommend you add an 'initialization' section to
all units and call Nilify() on all pointers/objects in that unit. This
will ensure that all pointers/objects start off as nil. Furthermore, you
should use the NilFree (for objects), NilDispose (for pointers created with
New), and NilFreeMem (for pointers created with GetMem) instead of their
standard counterparts. These procedures are safe to call on nil pointer/
objects, as they check for nil before performing any action. After freeing
the memory allocated to the pointer/object, they reset the pointer to nil. If
you are strict in your use of these procedures, your risk of accessing stale
pointer is greatly reduced. (Of course, you can still get stale pointers from
the VCL as it obviously doesn't use these functions.)
}
{==============================================================================}
interface
{------------------------------------------------------------------------------}
{ Checks a pointer against nil }
{ NOTE: This function differs from Assigned() in that Assigned() requires a }
{ variable, whereas IsNil() does not. }
function IsNil(const p: Pointer): Boolean;
{ Sets a pointer to nil }
procedure Nilify(var p);
{ Frees a non-nil object, then sets it to nil }
procedure NilFree(o: TObject);
{ Frees a non-nil pointer created by New, then sets it to nil }
procedure NilDispose(var p: Pointer);
{ Frees a non-nil pointer, then sets it to nil }
procedure NilFreeMem(var p: Pointer; size: Word);
{==============================================================================}
implementation
{------------------------------------------------------------------------------}
function IsNil(const p: Pointer): Boolean;
begin
Result := (p = nil);
end;
{------------------------------------------------------------------------------}
procedure Nilify(var p);
begin
Pointer(p) := nil;
end;
{------------------------------------------------------------------------------}
procedure NilFree(o: TObject);
begin
if not IsNil(o) then begin
o.Free;
Nilify(o);
end;
end;
{------------------------------------------------------------------------------}
procedure NilDispose(var p: Pointer);
begin
if not IsNil(p) then begin
Dispose(p);
Nilify(p);
end;
end;
{------------------------------------------------------------------------------}
procedure NilFreeMem(var p: Pointer; size: Word);
begin
if not IsNil(p) then begin
FreeMem(p,size);
Nilify(p);
end;
end;
end.
Eddie Shipman <eshipman@inetport.com>
For anyone needing to do multi-language apps and don't want to write a lot of code checking what language the program is running, see below. I compiled a stringtable resource into my exe and this is how I used it for multi-language dialogs.Instead of using the Runtime directives to check what language, I used a runtime variable to set the index for the messages into the stringtable and then load the messages from there depending upon the language. You could also create different stringtables for each language and then compiling them in by using the compile directives.
Here is some example code, give it a try:
unit French1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, IniFiles;
type
TForm1 = class(TForm)
Button1: TButton;
procedure FormActivate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
StringIndex : Integer;
implementation
{$R *.DFM}
{$R MULTLANG.RES}
{ Here is the way the resource file for this project looks:
1, "Attention"
2, "No Condition definition selected!"
3, "Always"
4, "Cannot delete the 'always' condition."
5, "Confirmation"
6, "Delete the condition?"
7, "Yes"
8, "No"
9, "Attention"
10, "Pas de condition SelectionnΘe"
11, "Toulours"
12, "Ne peux effacer la condition 'Toujours'"
13, "Confirmation"
14, "Effacer cette condition?"
15, "&Oui"
16, "&Non"
}
procedure TForm1.FormActivate(Sender: TObject);
var
{inifile : TIniFile; Optional}
ProgramLanguage : String;
begin
{ Here, I just set it to French }
ProgramLanguage := 'fra';
{ You can optionally get the language from Win.INI:}
{inifile := TInifile.Create('WIN.INI');
ProgramLanguage := inifile.ReadString('intl', 'sLanguage', 'enu');
inifile.Free;}
{ Forgive me if I leave out any languages, Tthese are th only ones
in my setup.inf for my copy of Windows.
dan = Danish
nld = Dutch
enu = English (American)
eng = English (International)
fin = Finnish
fra = French
frc = French Canadian
deu = German
isl = Icelandic
ita = Italian
nor = Norwegian
ptg = Portuguese
esp = Spanish
esn = Spanish (Modern)
sve = Swedish
}
if ProgramLanguage = 'enu' then
begin
StringIndex := 0;
end
else
if ProgramLanguage = 'fra' then
begin
StringIndex := 8;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i,j,k : integer;
DialogForm : tform;
begin
Application.NormalizeTopMosts;
{no Condition Selected!}
DialogForm := CreateMessageDialog(LoadStr(StringIndex+2),mtWarning,[mbOK]);
{Attention}
DialogForm.caption := LoadStr(StringIndex + 1);
DialogForm.showmodal;
Application.RestoreTopMosts;
{Cannot Delete the 'always' condition}
DialogForm := CreateMessageDialog(LoadStr(StringIndex+4),mtWarning,[mbOK]);
{Always}
DialogForm.caption := LoadStr(StringIndex + 3);
DialogForm.showmodal;
Application.RestoreTopMosts;
{Delete the condition?}
DialogForm := CreateMessageDialog(LoadStr(StringIndex+6),mtInformation, [mbYes, mbNo]);
{confirmation}
DialogForm.caption := LoadStr(StringIndex + 5);
for j := 0 to DialogForm.controlCount-1 do
begin
if DialogForm.controls[j] is tButton then
with tButton(DialogForm.controls[j]) do
begin
if caption = '&Yes' then caption := LoadStr(StringIndex+7);
if caption = '&No' then caption := LoadStr(StringIndex+8);
end;
end;
DialogForm.showmodal;
end;
end.
Michael Ax <ax@HREF.COM>
unit UcShell;
{ Author: Michael Ax http://www.axsystems.com/
Copyright (c) 1995..1997 Michael Ax. All Rights Reserved.
This source code is part of TPack from HREF Tools Corp.
Obtain purchasing and additional information by sending an email to
software@href.com (any subject, any message)...
or visit us on the web at http://www.href.com/software/
}
interface
uses Classes, SysUtils, Windows, ShellApi, Forms;
{---------------------------------------------------------------}
function WinExecutableName(const AssociatedFile:string):String;
procedure WinShellOpen(const AssociatedFile:string);
procedure WinShellPrint(const AssociatedFile:string);
procedure WinShellExecute(const Operation,AssociatedFile:string);
{---------------------------------------------------------------}
implementation
Const
cStrBufSize= 80;
{---------------------------------------------------------------}
function WinExecutableName(const AssociatedFile:string):String;
//HINSTANCE FindExecutable(
// LPCTSTR lpFile, // pointer to string for filename
// LPCTSTR lpDirectory, // pointer to string for default directory
// LPTSTR lpResult // pointer to buffer for string for executable file
on return
// );
begin
SetLength(result,cStrBufSize); //ucshell
FindExecutable(pchar(AssociatedFile),'',pchar(result));
SetLength(result,strlen(pchar(result)));
end;
//
procedure WinShellExecute(const Operation,AssociatedFile:string);
var
a1:string;
begin
a1:=Operation;
if a1='' then
a1:='open';
ShellExecute(
application.handle //hWnd: HWND
,pchar(a1) //Operation: PChar
,pchar(AssociatedFile) //FileName: PChar
,'' //Parameters: PChar
,'' //Directory: PChar
,SW_SHOWNORMAL //ShowCmd: Integer
);
// GetLastErrorString(0); //ucdialog
end;
procedure WinShellPrint(const AssociatedFile:string);
begin
WinShellExecute('print',AssociatedFile);
end;
procedure WinShellOpen(const AssociatedFile:string);
begin
WinShellExecute('open',AssociatedFile);
end;
{-----------------------------------------------------------------}
end.
Keith Anderson <keith@PURESCIENCE.COM>
Use the following to login:MapiLogon(application.handle,nil,nil,mapi_use_default,0,@mapihandle)
MapiSendMail(mapihandle, 0,MapiMessage,0, 0);
Also make sure Exchange is running using the GetWindowHandle API function, and if it's not, use ShellExecute (or whatever) to launch it first.
From: richardp@calweb.com (Coyote)
In the past few days there have been more than a few questions on this group indicating a lack of understanding about object instantiation. I'm guessing that these have been beginners, but in one case the questioner was taking a class on Delphi. I'd hope that an instructor would at least *try* to explain the subject.Anyway, for all of you having pointer errors, exceptions, and GPFs, take a quick look at this.
When you declare a variable of some classtype such as...
var MyVar: TMyClass;
Delphi handles all the messiness of memory allocation and disposal for you, but you do have to do a little bit of work. When you use one of Delphi's classes, or derive one of your own, you must instantiate the object. What that means is this: you must allocate the memory for it and set the pointer to that block of memory. In some languages that would be ugly; in Delphi it's as easy as...
MyVar := TMyClass.Create;
In the end, all you really need to remember is this...
procedure Example; var MyObj: TMyClass; // a class that you've created MyList: TList; // a native class begin MyObj := TMyClass.Create; // now MyObj is instantiated--it means something MyList := TList.Create; // same for MyList .... do some stuff here .... MyList.Free; // MyList's resources are cleared from the heap MyObj.Free; // same for MyObj end;
From: hallvard@falcon.no (Hallvard Vassbotn)
program VarPar;
{ A simple program to demonstrate use of type-safe variable number of
parameters in Delphi.
Written Mars 1995 by Hallvard Vassbotn
hallvard@falcon.no
}
uses WinCrt, SysUtils;
{ These are predefined in System:
const
vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
vtExtended = 3;
vtString = 4;
vtPointer = 5;
vtPChar = 6;
vtObject = 7;
vtClass = 8;
type
TVarRec = record
case Integer of
vtInteger: (VInteger: Longint; VType: Byte);
vtBoolean: (VBoolean: Boolean);
vtChar: (VChar: Char);
vtExtended: (VExtended: PExtended);
vtString: (VString: PString);
vtPointer: (VPointer: Pointer);
vtPChar: (VPChar: PChar);
vtObject: (VObject: TObject);
vtClass: (VClass: TClass);
end;
}
const
TypeNames : array [vtInteger..vtClass] of PChar =
('Integer', 'Boolean', 'Char', 'Extended', 'String',
'Pointer', 'PChar', 'Object', 'Class');
{
According to the on-line docs (search for TVarRec), array of const
parameters are treated like array of TVarRec by the compiler.
This example will work just as well if you change the declaration of
TestMultiPar to:
procedure TestMultiPar(const Args: array of TVarRec);
This would make the implementation of the routine cleaner (no absolute
variable declaration), but the interface would be less understandable
to the user of the routine.
The compiler looks at the parameters and builds the array directly on the
stack. For each item in the array it also sets the VType field to one
of the pre-defined constants vtXXXX. The actual value is always sent as
four bytes of information. For the Boolean and Char types, only the first
byte contains useful information.
So, go ahead, now you can write all those neat routines with variable
number of parameters - and still keep the type safety!
}
function PtrToHex(P: pointer): string;
begin
Result := IntToHex(Seg(P^), 4) + ':' + IntToHex(Ofs(P^), 4);
end;
procedure TestMultiPar(const Args: array of const);
var
ArgsTyped : array [0..$fff0 div sizeof(TVarRec)] of TVarRec absolute Args;
i : integer;
begin
for i := Low(Args) to High(Args) do
with ArgsTyped[i] do
begin
Write('Args[', i, '] : ', TypeNames[VType], ' = ');
case VType of
vtInteger: writeln(VInteger);
vtBoolean: writeln(VBoolean);
vtChar: writeln(VChar);
vtExtended: writeln(VExtended^:0:4);
vtString: writeln(VString^);
vtPointer: writeln(PtrToHex(VPointer));
vtPChar: writeln(VPChar);
vtObject: writeln(PtrToHex(Pointer(VObject)));
vtClass: writeln(PtrToHex(Pointer(VClass)));
end;
end;
end;
var
MyObj : TObject;
begin
Writeln('Test of type-safe variable number of parameters in Delphi:');
MyObj := TObject.Create;
TestMultiPar([123, 45.67, PChar('ASCIIZ'), 'Hello, world!', true, 'X',
@ShortDayNames, TObject, MyObj]);
MyObj.Free;
{ To verify that the type-safety is used in the supplied formatting routines,
try this: }
writeln(Format('%d', ['hi']));
{ The supplied parameter is not of the type expected. The '%d' format string
signals that the parameter should be an integer value, but instead we
send a string. At run-time this will generate a exception, and if you
have enabled IDE-trapping of exceptions, Delphi will show you the offending
line. Using c-type sprintf funtions like this will result in undefined
behaviour (read: system crash, GP or whatever) }
end.
From: delarosa@ix.netcom.com (Luis de la Rosa)
I have finally created a custom component, TWrapGrid that allows you to use a TStringGrid, but also wrap the text in a cell. This is the beta version, so I encourage you to experiment with it, try it out, and send me comments on what you think of it. When you use it, remember to se the RowHeights (or DefaultRowHeight) large enough so that when it wraps, it shows up in the cell.To install, copy the following text and paste it into a Unit. Save it under the name 'Wrapgrid.PAS'. Then follow the directions I put in the header of the component.
I'm also looking for feedback on this component, so please try it and tell me what you think. Here is the code!
{ This is a custom component for Delphi.
It is wraps text in a TStringGrid, thus the name TWrapGrid.
It was created by Luis J. de la Rosa.
E-mail: delarosa@ix.netcom.com
Everyone is free to use it, distribute it, and enhance it.
To use: Go to the 'Options' - 'Install Components' menu selection in Delphi.
Select 'Add'.
Browse for this file, which will be named 'Wrapgrid.PAS'.
Select 'OK'.
You have now added this to the Samples part of your component
palette.
After that, you can use it just like a TStringGrid.
Please send any questions or comments to delarosa@ix.netcom.com
Enjoy!
A few additional programming notes:
I have overridden the Create and DrawCell methods. Everything else should
behave just like a TStringGrid.
The Create sets the DefaultDrawing to False, so you don't need to.
Also, I am using the pure block emulation style of programming, making my
code easier to read.
}
unit Wrapgrid;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids;
type
TWrapGrid = class(TStringGrid)
private
{ Private declarations }
protected
{ Protected declarations }
{ This DrawCell procedure wraps text in the grid cell }
procedure DrawCell(ACol, ARow : Longint; ARect : TRect;
AState : TGridDrawState); override;
public
{ Public declarations }
{ The Create procedure is overriden to use the DrawCell procedure by
default }
constructor Create(AOwner : TComponent); override;
published
{ Published declarations }
end;
procedure Register;
implementation
constructor TWrapGrid.Create(AOwner : TComponent);
begin
{ Create a TStringGrid }
inherited Create(AOwner);
{ Make the drawing use our DrawCell procedure by default }
DefaultDrawing := FALSE;
end;
{ This DrawCell procedure wraps text in the grid cell }
procedure TWrapGrid.DrawCell(ACol, ARow : Longint; ARect : TRect;
AState : TGridDrawState);
var
Sentence, { What is left in the cell to output }
CurWord : String; { The word we are currently outputting }
SpacePos, { The position of the first space }
CurX, { The x position of the 'cursor' }
CurY : Integer; { The y position of the 'cursor' }
EndOfSentence : Boolean; { Whether or not we are done outputting the cell }
begin
{ Initialize the font to be the control's font }
Canvas.Font := Font;
with Canvas do begin
{ If this is a fixed cell, then use the fixed color }
if gdFixed in AState then begin
Pen.Color := FixedColor;
Brush.Color := FixedColor;
end
{ else, use the normal color }
else begin
Pen.Color := Color;
Brush.Color := Color;
end;
{ Prepaint cell in cell color }
Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
end;
{ Start the drawing in the upper left corner of the cell }
CurX := ARect.Left;
CurY := ARect.Top;
{ Here we get the contents of the cell }
Sentence := Cells[ACol, ARow];
{ for each word in the cell }
EndOfSentence := FALSE;
while (not EndOfSentence) do begin
{ to get the next word, we search for a space }
SpacePos := Pos(' ', Sentence);
if SpacePos > 0 then begin
{ get the current word plus the space }
CurWord := Copy(Sentence, 0, SpacePos);
{ get the rest of the sentence }
Sentence := Copy(Sentence, SpacePos + 1, Length(Sentence) - SpacePos);
end
else begin
{ this is the last word in the sentence }
EndOfSentence := TRUE;
CurWord := Sentence;
end;
with Canvas do begin
{ if the text goes outside the boundary of the cell }
if (TextWidth(CurWord) + CurX) > ARect.Right then begin
{ wrap to the next line }
CurY := CurY + TextHeight(CurWord);
CurX := ARect.Left;
end;
{ write out the word }
TextOut(CurX, CurY, CurWord);
{ increment the x position of the cursor }
CurX := CurX + TextWidth(CurWord);
end;
end;
end;
procedure Register;
begin
{ You can change Samples to whichever part of the Component Palette you want
to install this component to }
RegisterComponents('Samples', [TWrapGrid]);
end;
end.
From: dionkk@ix.netcom.com (Dion Kurczek)
Here's the source code for a resizable panel. Give the panel an align property of alClient, throw some controls on it, and watch them resize at run time when you resize the form. There is some code that prohibits resizing during design time, but this can be taken out. This may not be perfect, because I threw it together in a few minutes, but it's worked for me so far.
unit Elastic;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls;
type
TElasticPanel = class( TPanel )
private
FHorz, FVert: boolean;
nOldWidth, nOldHeight: integer;
bResized: boolean;
protected
procedure WMSize( var message: TWMSize ); message WM_SIZE;
public
nCount: integer;
constructor Create( AOwner: TComponent ); override;
published
property ElasticHorizontal: boolean read FHorz write FHorz default
TRUE;
property ElasticVertical: boolean read FVert write FVert default
TRUE;
end;
procedure Register;
implementation
constructor TElasticPanel.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
FHorz := TRUE;
FVert := TRUE;
nOldWidth := Width;
nOldHeight := Height;
bResized := FALSE;
end;
procedure TElasticPanel.WMSize( var message: TWMSize );
var
bResize: boolean;
xRatio: real;
i: integer;
ctl: TWinControl;
begin
Inc( nCount );
if Align = alNone then
bResize := TRUE
else
bResize := bResized;
if not ( csDesigning in ComponentState ) and bResize then
begin
if FHorz then
begin
xRatio := Width / nOldWidth;
for i := 0 to ControlCount - 1 do
begin
ctl := TWinControl( Controls[i] );
ctl.Left := Round( ctl.Left * xRatio );
ctl.Width := Round( ctl.Width * xRatio );
end;
end;
if FVert then
begin
xRatio := Height / nOldHeight;
for i := 0 to ControlCount - 1 do
begin
ctl := TWinControl( Controls[i] );
ctl.Top := Round( ctl.Top * xRatio );
ctl.Height := Round( ctl.Height * xRatio );
end;
end;
end
else
begin
nOldWidth := Width;
nOldHeight := Height;
end;
bResized := TRUE;
nOldWidth := Width;
nOldHeight := Height;
end;
procedure Register;
begin
RegisterComponents('Additional', [TElasticPanel]);
end;
end.
I'm writing a program in Delphi that is supposed to scan the size of a file in the background every hour. This is also supposed to happen when the application is inactive, it's should work as a watchdog in the background of win 95 and NT. How do you program this...??Here is some source code that should do what you want. I just created it now, and it is completely untested, but very similar to something I've already done, so it should work. It does make one assumption that you should be aware of. It assumes that it is started at the same time as Windows is (perhaps in the startup group), so it uses GetTickCount, which returns msec since Windows was started), to perform a task once each hour that Windows is running. This may or may not be what you had in mind. Also, the value returned by GetTickCount is really a DWORD, but is stored in a LongInt in Delphi which means that some of the larger values will wind up being negative (after about 25 days). The effect this will have on my hour checking algorythm is undetermined (I haven't really considered it). Similarly, the value will recycle once every 49.7 days which could cause the check to occur twice in less than an hour once every 49.7 days. This may or may not be a problem for you. At any rate, this should get you started. Enjoy!
program Project1;
uses Messages, Windows;
{$R *.RES}
function KeepRunning: Boolean;
var
Msg: TMsg;
begin
Result := True;
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin
if (Msg.Message = WM_QUIT) then Result := False;
DispatchMessage(Msg);
end;
end;
function OnTheHour: Boolean;
begin
{ This actually checks for one second (or less) }
{ into the hour to allow for the possibility we }
{ may not get a timeslice exactly on the hour }
Result := (GetTickCount mod
(1{hr} * 60{min} * 60{sec} * 1000{msec}) < 1000);
end;
const
filetocheck = 'c:\somedir\somefile.ext';
magicsize = 1000000;
var
f: file;
size: longint;
begin
{ keep ourself alive, and wait to be shut down }
while keeprunning do begin
{ see if we're on the hour }
if onthehour then begin
{ open file with a record size of 1 byte }
{ and check its size }
assignfile(f,filetocheck);
reset(f,1);
size := filesize(f);
closefile(f);
{ now we check our file condition }
if (size >= MAGICSIZE) then begin
{ Do something special here }
end;
{ Now wait until we're past our 'grace' }
{ period so we don't accidentally fire }
{ off multiple times in a row }
while (KeepRunning and OnTheHour) do
{nothing};
end;
end;
end.A while ago I saw some emails about round/different splashscreens. I saved this somewhere and now I can't find it.Also Neil Rubenking author of Delphi for Dummies and other good books posted this one one compuserve. It is donut shaped with a curved title bar and you can see and click on other programs through the hole! Create a new project and save the main unit so its name is RGNU.PAS. Paste in the following:
unit rgnu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, Menus;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
rTitleBar : THandle;
Center : TPoint;
CapY : Integer;
Circum : Double;
SB1 : TSpeedButton;
RL, RR : Double;
procedure TitleBar(Act : Boolean);
procedure WMNCHITTEST(var Msg: TWMNCHitTest);
message WM_NCHITTEST;
procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE);
message WM_NCACTIVATE;
procedure WMSetText(var Msg: TWMSetText);
message WM_SETTEXT;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
CONST
TitlColors : ARRAY[Boolean] OF TColor =
(clInactiveCaption, clActiveCaption);
TxtColors : ARRAY[Boolean] OF TColor =
(clInactiveCaptionText, clCaptionText);
procedure TForm1.FormCreate(Sender: TObject);
VAR
rTemp, rTemp2 : THandle;
Vertices : ARRAY[0..2] OF TPoint;
X, Y : INteger;
begin
Caption := 'OOOH! Doughnuts!';
BorderStyle := bsNone; {required}
IF Width > Height THEN Width := Height
ELSE Height := Width; {harder to calc if width <> height}
Center := Point(Width DIV 2, Height DIV 2);
CapY := GetSystemMetrics(SM_CYCAPTION)+8;
rTemp := CreateEllipticRgn(0, 0, Width, Height);
rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4),
3*(Width DIV 4), 3*(Height DIV 4));
CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
SetWindowRgn(Handle, rTemp, True);
DeleteObject(rTemp2);
rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4);
rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
Vertices[0] := Point(0,0);
Vertices[1] := Point(Width, 0);
Vertices[2] := Point(Width DIV 2, Height DIV 2);
rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
DeleteObject(rTemp);
RL := ArcTan(Width / Height);
RR := -RL + (22 / Center.X);
X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR));
Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR));
SB1 := TSpeedButton.Create(Self);
WITH SB1 DO
BEGIN
Parent := Self;
Left := X;
Top := Y;
Width := 14;
Height := 14;
OnClick := Button1Click;
Caption := 'X';
Font.Style := [fsBold];
END;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
End;
procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
Inherited;
WITH Msg DO
WITH ScreenToClient(Point(XPos,YPos)) DO
IF PtInRegion(rTitleBar, X, Y) AND
(NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN
Result := htCaption;
end;
procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
Inherited;
TitleBar(Msg.Active);
end;
procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
Inherited;
TitleBar(Active);
end;
procedure TForm1.TitleBar(Act: Boolean);
VAR
TF : TLogFont;
R : Double;
N, X, Y : Integer;
begin
IF Center.X = 0 THEN Exit;
WITH Canvas DO
begin
Brush.Style := bsSolid;
Brush.Color := TitlColors[Act];
PaintRgn(Handle, rTitleBar);
R := RL;
Brush.Color := TitlColors[Act];
Font.Name := 'Arial';
Font.Size := 12;
Font.Color := TxtColors[Act];
Font.Style := [fsBold];
GetObject(Font.Handle, SizeOf(TLogFont), @TF);
FOR N := 1 TO Length(Caption) DO
BEGIN
X := Center.X-Round((Center.X-6)*Sin(R));
Y := Center.Y-Round((Center.Y-6)*Cos(R));
TF.lfEscapement := Round(R * 1800 / pi);
Font.Handle := CreateFontIndirect(TF);
TextOut(X, Y, Caption[N]);
R := R - (((TextWidth(Caption[N]))+2) / Center.X);
IF R < RR THEN Break;
END;
Font.Name := 'MS Sans Serif';
Font.Size := 8;
Font.Color := clWindowText;
Font.Style := [];
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
WITH Canvas DO
BEGIN
Pen.Color := clBlack;
Brush.Style := bsClear;
Pen.Width := 1;
Pen.Color := clWhite;
Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0);
Pen.Color := clBlack;
Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height);
TitleBar(Active);
END;
end;
end.
For ScreenSaver documentation, see Lucian Wischik's Page at...
http://classic.physiol.cam.ac.uk/scr/SCRB_TEC.HTM or
http://classic.physiol.cam.ac.uk/scr/SCRB_GEN.HTM
For sample sources, download Meik Weber's Saver from...
http://sunsite.icm.edu.pl/delphi/authors/a782.htm Hope this helps. Shuji maeda@nn.iij4u.or.jp