## 2005. április 30., szombat

### How to count the number of ones in a binary word

Problem/Question/Abstract:

How to count the number of ones in a binary word

This was written (but not necessarily invented) by Paul King. The algorithm counts the number of ones in a binary word. You could of course just look at each bit and count how many of them are ones. But that takes as many cycles as the number of bits in a word. This clever algorithm takes as many cycles as the number of ones in the word, so on average is faster (unless all your data consists of words in which all the bits are ones). I don't know if it is well known, but I have frequently shown it to younger programmers, who are always surprised by it.

I only ever saw the algorithm in assembler, but as a recursive Pascal function it would be something like this. (Asssuming that X and Y gives the bitwise 'and' of X and Y).

function CountBits(X: word): integer;
{return the number of bits that are ones in X}
begin
if (x = 0) then
CountBits := 0
else
CountBits := 1 + CountBits(X and (X - 1));
end;

This works because if X is not zero, (X and (X-1)) always has exactly one fewer ones in it than X does.

Of course making it recursive would slow it down, so I suppose the non-recursive version would be better. Something like this:

function CountBits(X: word): integer;
{return number of bits that are ones in X}
var
temp: word;
result: integer;
begin
temp := X;
result := 0;
while temp < > 0 do
begin
result := result + 1;
temp := (temp and (temp - 1));
end;
CountBits := result;
end;

Your non-recursive implementation can be optimized a bit further. Modern (Delphi) Pascals have a built-in "result" variable within functions. Beyond other benefits, it makes renaming functions easier, too. No hunting through for other internal name references.

Also: If you're not making the parameter a const parameter, I find it easier to read (and more efficient?) to just use the parameter in the calculations. (No need for the temp var.) Delphi would probably optimize that immediately to a register variable/ parameter, too. I also expanded the parameter and temp var. to an integer; words are only 16 bits. Integers will "grow" with the compiler and available hardware support to the largest comfortably-handled integer size within the environment.

So you'd end up with something like:

function CountBits(X: integer): integer;
{return number of bits that are ones in X}
begin
result := 0;
while x < > 0 do
begin
inc(result);
X := (X and (X - 1));
end;
end;

I've seen this before, but it smacks of "tricks" (which I avoid) so I fear that when I needed it I did it the obvious way by a preprepared table:

function countbits(n: cardinal): integer;
const
bytebits: array[0..255] of byte = (0, 1, 1, 2, 1, 2, 2, 3, 1...);
{these values generated by your program??}
begin
result := 0;
repeat
inc(result, bytebits[n and \$FF];
n := n shr 8;
until
n = 0;
end;

Should be a lot faster and you can trade off storage against speed by using a 4-bit, 8-bit, 12-bit
or 16-bit initial array.

## 2005. április 29., péntek

Problem/Question/Abstract:

Get the MicroSoft Access '97 password.

const
XorArr: array[0..12] of Byte = (\$86, \$FB, \$EC, \$37, \$5D, \$44, \$9C, \$FA, \$C6, \$5E,
\$28, \$E6, \$13);

var
I: Integer;
Arr: array[0..12] of Byte;
S1: string;
FI: file of Byte;
By: Byte;
Access97: Boolean;
FileError: Boolean;

begin
// Init
FileError := False;
Access97 := True;

// Open file
AssignFile(FI, Filename);
Reset(FI);

I := 0;
repeat
if not Eof(FI) then
begin
Inc(I);
end;
until (I = \$42) or Eof(FI);
if Eof(FI) then
FileError := True;

for I := 0 to 12 do
if not Eof(FI) then

if Eof(FI) then
FileError := True;

//Close file
CloseFile(FI);

S1 := '';
for I := 0 to 12 do
S1 := S1 + Chr(Arr[I]);

// Is nul string?
if S1 = #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 then
Access97 := False;

// Decode string
S1 := '';
for I := 0 to 12 do
S1 := S1 + Chr(Arr[I] xor XORArr[I]);

// Find end of string
I := 0;
repeat
Inc(I);
until (S1[I] = #0) or (I = 14);
if I <= 14 then
S1 := Copy(S1, 1, I - 1);

// Gather the results
if Access97 then
begin
if Length(S1) > 0 then
Result := 'The password is: ' + S1 + '.'
else
Result := 'The file is NOT password protected.';
end
else
Result := 'The file is not an Access 97 file / wrong format.';

if FileError then
Result := 'File error';
end;

## 2005. április 28., csütörtök

### How to position the cursor on the right-hand side of a TEdit

Problem/Question/Abstract:

I want to write an Edit component, but I want the cursor to stay on the right when the user types in new characters.

procedure TForm1.Edit1Change(Sender: TObject);
begin
if IsChanging then
exit; {Avoid recursion}
IsChanging := true;
try
{Remove the first character}
Edit1.Text := copy(Edit1.Text, 2, length(Edit1.Text) - 1);
{And move the cursor to the end of the text}
Edit1.SelStart := length(Edit1.Text);
finally
IsChanging := false;
end;
end;

At design time (or in Create), put several spaces as Edit1.Text. They will be replaced one by one with characters typed by the user. IsChanging is a private variable of type boolean.

## 2005. április 27., szerda

### Detect if Excel is installed

Problem/Question/Abstract:

In the application I am writing I need to get data from an Excel spreadsheet and then insert it into a database. I am going to automate Excel. What I would like to know is how I can detect to see if excel is installed, and if it is, what version of Excel is on the user's computer. How can I do this?

{ ... }
var
ClassID: TCLSID;
strOLEObject: string;
begin
strOLEObject := 'Excel.Application';
if (CLSIDFromProgID(PWideChar(WideString(strOLEObject)), ClassID) = S_OK) then
begin
{application is installed}
end
else
begin
{application is not installed}
end
end;

To get the version, just read Version property of Excel.Application:

xls := CreateOLEObject('Excel.Application');
v := xls.Version;

## 2005. április 26., kedd

### How can I put a button on a form's caption bar?

Problem/Question/Abstract:

I've seen some programs that add text or buttons on the title bar of a form. How can I do this in Delphi?

Introduction

I got my first insight into solving this problem when I wrote a previous tip that covered rolling up the client area of forms so that only the caption bar showed. In my research for that tip, I came across the WMSetText message that is used for drawing on a form's canvas. I wrote a sample application to test drawing in the caption area. The only problem with my original code was that the button would disappear when I resized or moved the form.

I turned to Delphi/Pascal guru Neil Rubenking for help. He pointed me in the direction of his book, Delphi Programming Problem Solver, which contains an example for doing this exact thing. The code below is an adaptation of the example in his book. The most fundamental difference between our examples is that I wanted to make a speedbutton with a bitmap glyph, and Neil actually drew a shape directly on the canvas. He also placed the button created in 16-bit Delphi on the left-hand side of the frame, and Win32 button placement was on the right. I wanted my buttons to be placed on the right for both versions, so I wrote appropriate code to handle that. The deficiency in my code was the lack of handlers for activation and painting in the non-client area of the form.

One thing I'm continually discovering is that there is a very definitive structure in Windows &mdash a definite hierarchy of functions. I've realized that the thing that makes Windows programming at the API level difficult is the sheer number of functions in the API set. For those who are reluctant to dive into the WinAPI, think in terms of categories first, then narrow your search. You'll find that doing it this way will make your life much easier.

What makes all of this work is Windows messages. The messages we're interested in here are not the usual Windows messages handled by plain-vanilla Windows apps, but are specific to an area of a window called the non-client area. The client area of a window is the part inside the border where most applications present information. The non-client area consists of the window's borders, caption bar, system menu and sizing buttons. The Windows messages that pertain to this area have the naming convention of WM_NCMessageType. Taking the name apart, 'WM' stands for Windows Message, 'NC' stands for Non-client area, and MessageType is the type of message being trapped. For example, WM_NCPaint is the paint message for the non-client area. Taking into account the hierarchical and categorical nature of the Windows API, nomenclature is a very big part of it; especially with Windows messages. If you look in the help file under messages, peruse through the list of messages and you will see the order that is followed.

Let's look at a list of things that we need to consider to add a button to the title bar of a form:

We need to have a function to draw the button.
We'll have to trap drawing and painting events so that our button stays visible when the form activates, resizes or moves.
We're dropping a button on the title bar, so we have to have a way of trapping for a mouse click on the button.

I'll now discuss these topics, in the above order.

Drawing a TRect as a Button

You can't drop VCL objects onto a non-client area of a window, but you can draw on it and simulate the appearance of a button. In order to perform drawing in the title bar of a window, you have to do three very important things, in order:

You must get the current measurements of the window and the size of the frame bitmaps so you know what area to draw in and how big to draw the rectangle.
Then you have to define a TRect structure with the proper size and position within the title bar.
Finally, you have to draw the TRect to appear as a button, then add any glyphs or text you might want to draw to the buttonface.

All of this is accomplished in a single call. For this program we make a call to the DrawTitleButton procedure, which is listed below:

procedure TTitleBtnForm.DrawTitleButton;
var
bmap: TBitmap; {Bitmap to be drawn - 16 X 16 : 16 Colors}
XFrame, {X and Y size of Sizeable area of Frame}
YFrame,
XTtlBit, {X and Y size of Bitmaps in caption}
YTtlBit: Integer;
begin
{Get size of form frame and bitmaps in title bar}
XFrame := GetSystemMetrics(SM_CXFRAME);
YFrame := GetSystemMetrics(SM_CYFRAME);
XTtlBit := GetSystemMetrics(SM_CXSIZE);
YTtlBit := GetSystemMetrics(SM_CYSIZE);

{\$IFNDEF WIN32}
TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
YFrame - 1,
XTtlBit + 2,
YTtlBit + 2);

{\$ELSE} {Delphi 2.0 positioning}
if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
YFrame - 1,
XTtlBit + 2,
YTtlBit + 2)
else
TitleButton := Bounds(Width - XFrame - 4 * XTtlBit + 2,
XFrame + 2,
XTtlBit + 2,
YTtlBit + 2);
{\$ENDIF}

Canvas.Handle := GetWindowDC(Self.Handle); {Get Device context for drawing}
try
{Draw a button face on the TRect}
DrawButtonFace(Canvas, TitleButton, 1, bsAutoDetect, False, False, False);
bmap := TBitmap.Create;
with TitleButton do
{\$IFNDEF WIN32}
Canvas.Draw(Left + 2, Top + 2, bmap);
{\$ELSE}
if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
Canvas.Draw(Left + 2, Top + 2, bmap)
else
Canvas.StretchDraw(TitleButton, bmap);
{\$ENDIF}

finally
ReleaseDC(Self.Handle, Canvas.Handle);
bmap.Free;
Canvas.Handle := 0;
end;
end;

Step 1 above is accomplished by making four calls to the WinAPI function GetSystemMetrics, asking the system for the width and height of the window that can be sized (SM_CXFRAME and SM_CYFRAME), and the size of the bitmaps contained on the title bar (SM_CXSIZE and SM_CYSIZE).

Step 2 is performed with the Bounds function, which returns a TRect defined by the size and position parameters that are supplied to it. Notice that I used some conditional compiler directives here. This is because the size of the title bar buttons in Windows 95 and Windows 3.1 are different, so they have to be sized differently. And since I wanted to be able to compile this in either version of Windows, I used a test for the predefined symbol, WIN32, to see which version of Windows the program is compiled under. However, since the Windows NT UI is the same as Windows 3.1, it's necessary to grab further version information under the Win32 conditional to see if the Windows version is Windows NT. If so, we define the TRect to be just like the Windows 3.1 TRect.

To perform Step 3, we make a call to the Buttons unit's DrawButtonFace to draw button features within the TRect that we defined. As added treat, I included code to draw a bitmap in the button. You'll see that I used a conditional compiler directive to draw the bitmap under different versions of Windows. I did this because the bitmap I used was 16x16 pixels, which might be too big for Win95 buttons. So I used StretchDraw under Win32 to stretch the bitmap to the size of the button.

Trapping the Drawing and Painting Events

You must make sure that the button will stay visible every time the form repaints itself. Painting occurs in response to activation and resizing, which fire off paint and text setting messages that will redraw the form. If you don't have a facility to redraw your button, you'll lose it every time a repaint occurs. So what we have to do is write event handlers which will perform their default actions and redraw our button when they fire off. The following four procedures handle the paint triggering and painting events:

{Paint triggering events}

procedure TForm1.WMNCActivate(var Msg: TWMNCActivate);
begin
inherited;
DrawTitleButton;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
Perform(WM_NCACTIVATE, Word(Active), 0);
end;

{Painting events}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
begin
inherited;
DrawTitleButton;
end;

procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
inherited;
DrawTitleButton;
end;

Every time one of these events fires off, it makes a call to the DrawTitleButton procedure. This will ensure that our button is always visible on the title bar. Notice that we use the default handler OnResize on the form to force it to perform a WM_NCACTIVATE.

Handling Mouse Clicks

Now that we've got code that draws our button and ensures that it's always visible, we have to handle mouse clicks on the button. The way we do this is with two procedures. The first procedure tests to see if the mouse click was in the area of our button, then the second procedure actually performs the code execution associated with our button. Let's look at the code:

{Mouse-related procedures}

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
{Check to see if the mouse was clicked in the area of the button}
with Msg do
if PtInRect(TitleButton, Point(XPos - Left, YPos - Top)) then
Result := htTitleBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htTitleBtn) then
ShowMessage('You pressed the new button');
end;

The first procedure WMNCHitTest(var Msg : TWMNCHitTest) is a hit tester message to determine where the mouse was clicked in the non-client area. In this procedure we test if the point defined by the message was within the bounds of our TRect by using the PtInRect function. If the mouse click was performed in the TRect, then the result of our message is set to htTitleBtn, which is a constant that was declared as htSizeLast + 1. htSizeLast is a hit test constant generated by hit test events to test where the last hit occurred.

The second procedure is a custom handler for a left mouse click on a button in the non-client area. Here we test if the hit test result was equal to htTitleBtn. If it is, we show a message. You can make any call you choose to at this point.

Putting it All Together

Let's look at the entire code in the form to see how it all works together:

unit Capbtn;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Buttons;

type
TTitleBtnForm = class(TForm)
procedure FormResize(Sender: TObject);
private
TitleButton: TRect;
procedure DrawTitleButton;
{Paint-related messages}
procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;
procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
{Mouse down-related messages}
procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
function GetVerInfo: DWORD;
end;

var
TitleBtnForm: TTitleBtnForm;

const
htTitleBtn = htSizeLast + 1;

implementation
{\$R *.DFM}

procedure TTitleBtnForm.DrawTitleButton;
var
bmap: TBitmap; {Bitmap to be drawn - 16 X 16 : 16 Colors}
XFrame, {X and Y size of Sizeable area of Frame}
YFrame,
XTtlBit, {X and Y size of Bitmaps in caption}
YTtlBit: Integer;
begin
{Get size of form frame and bitmaps in title bar}
XFrame := GetSystemMetrics(SM_CXFRAME);
YFrame := GetSystemMetrics(SM_CYFRAME);
XTtlBit := GetSystemMetrics(SM_CXSIZE);
YTtlBit := GetSystemMetrics(SM_CYSIZE);

{\$IFNDEF WIN32}
TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
YFrame - 1,
XTtlBit + 2,
YTtlBit + 2);

{\$ELSE} {Delphi 2.0 positioning}
if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
YFrame - 1,
XTtlBit + 2,
YTtlBit + 2)
else
TitleButton := Bounds(Width - XFrame - 4 * XTtlBit + 2,
XFrame + 2,
XTtlBit + 2,
YTtlBit + 2);
{\$ENDIF}

Canvas.Handle := GetWindowDC(Self.Handle); {Get Device context for drawing}
try
{Draw a button face on the TRect}
DrawButtonFace(Canvas, TitleButton, 1, bsAutoDetect, False, False, False);
bmap := TBitmap.Create;
with TitleButton do
{\$IFNDEF WIN32}
Canvas.Draw(Left + 2, Top + 2, bmap);
{\$ELSE}
if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
Canvas.Draw(Left + 2, Top + 2, bmap)
else
Canvas.StretchDraw(TitleButton, bmap);
{\$ENDIF}

finally
ReleaseDC(Self.Handle, Canvas.Handle);
bmap.Free;
Canvas.Handle := 0;
end;
end;

{Paint triggering events}

procedure TTitleBtnForm.WMNCActivate(var Msg: TWMNCActivate);
begin
inherited;
DrawTitleButton;
end;

procedure TTitleBtnForm.FormResize(Sender: TObject);
begin
Perform(WM_NCACTIVATE, Word(Active), 0);
end;

{Painting events}

procedure TTitleBtnForm.WMNCPaint(var Msg: TWMNCPaint);
begin
inherited;
DrawTitleButton;
end;

procedure TTitleBtnForm.WMSetText(var Msg: TWMSetText);
begin
inherited;
DrawTitleButton;
end;

{Mouse-related procedures}

procedure TTitleBtnForm.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
{Check to see if the mouse was clicked in the area of the button}
with Msg do
if PtInRect(TitleButton, Point(XPos - Left, YPos - Top)) then
Result := htTitleBtn;
end;

procedure TTitleBtnForm.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htTitleBtn) then
ShowMessage('You pressed the new button');
end;

function TTitleBtnForm.GetVerInfo: DWORD;
var
verInfo: TOSVERSIONINFO;
begin
verInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(verInfo) then
Result := verInfo.dwPlatformID;
{Returns:
VER_PLATFORM_WIN32s             Win32s on Windows 3.1
VER_PLATFORM_WIN32_WINDOWS        Win32 on Windows 95
VER_PLATFORM_WIN32_NT           Windows NT }
end;

end.

Suggestions for Exploring

You might want to play around with this code a bit to customize it to your own needs. For instance, if you want to add a bigger button, add pixels to the XTtlBit var. You can also mess around with creating a floating toolbar that is purely on the title bar. Also, now that you have a means of interrogating what's going on in the non-client area of the form, you might want to play around with the default actions taken with the other buttons like the System Menu button to perhaps display your own custom menu.

Take heed, though: Playing around with Windows messages can be dangerous. Save your work constantly, and be prepared for some system crashes while you experiment.

## 2005. április 25., hétfő

### Getting a list of installed services

Problem/Question/Abstract:

Want to get a list of active, inactive or all Windows services?

Following function can help you to do this, but be sure to read other Windows services related tips for details.

const
//
// Service Types
//
SERVICE_KERNEL_DRIVER = \$00000001;
SERVICE_FILE_SYSTEM_DRIVER = \$00000002;
SERVICE_RECOGNIZER_DRIVER = \$00000008;

SERVICE_DRIVER =
(SERVICE_KERNEL_DRIVER or
SERVICE_FILE_SYSTEM_DRIVER or
SERVICE_RECOGNIZER_DRIVER);

SERVICE_WIN32_OWN_PROCESS = \$00000010;
SERVICE_WIN32_SHARE_PROCESS = \$00000020;
SERVICE_WIN32 =
(SERVICE_WIN32_OWN_PROCESS or
SERVICE_WIN32_SHARE_PROCESS);

SERVICE_INTERACTIVE_PROCESS = \$00000100;

SERVICE_TYPE_ALL =
(SERVICE_WIN32 or
SERVICE_DRIVER or
SERVICE_INTERACTIVE_PROCESS);

uses WinSvc;

//-------------------------------------
// Get a list of services
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \\SERVER
//   empty = local machine
//
// dwServiceType
//   SERVICE_WIN32,
//   SERVICE_DRIVER or
//   SERVICE_TYPE_ALL
//
// dwServiceState
//   SERVICE_ACTIVE,
//   SERVICE_INACTIVE or
//   SERVICE_STATE_ALL
//
// slServicesList
//   TStrings variable to storage
//

function ServiceGetList(
sMachine: string;
dwServiceType,
dwServiceState: DWord;
slServicesList: TStrings)
: boolean;
const
//
// assume that the total number of
// services is less than 4096.
// increase if necessary
cnMaxServices = 4096;

type
TSvcA = array[0..cnMaxServices]
of TEnumServiceStatus;
PSvcA = ^TSvcA;

var
//
// temp. use
j: integer;

//
// service control
// manager handle
schm: SC_Handle;

//
// bytes needed for the
// next buffer, if any
nBytesNeeded,

//
// number of services
nServices,

//
// pointer to the
nResumeHandle: DWord;

//
// service status array
ssa: PSvcA;
begin
Result := false;

// connect to the service
// control manager
schm := OpenSCManager(
PChar(sMachine),
nil,
SC_MANAGER_ALL_ACCESS);

// if successful...
if (schm > 0) then
begin
nResumeHandle := 0;

New(ssa);

EnumServicesStatus(
schm,
dwServiceType,
dwServiceState,
ssa^[0],
SizeOf(ssa^),
nBytesNeeded,
nServices,
nResumeHandle);

//
// assume that our initial array
// was large enough to hold all
// entries. add code to enumerate
// if necessary.
//

for j := 0 to nServices - 1 do
begin
slServicesList.
ssa^[j].lpDisplayName));
end;

Result := true;

Dispose(ssa);

// close service control
// manager handle
CloseServiceHandle(schm);
end;
end;

To get a list of all Windows services into a listbox named ListBox1:

ServiceGetList('', SERVICE_WIN32, SERVICE_STATE_ALL, ListBox1.Items);

## 2005. április 24., vasárnap

### Delphi IDE freezes every 5 minutes for one minute

Problem/Question/Abstract:

My Delphi IDE freezes every five or six minutes for approximately 50 seconds. While the IDE is frozen, I can switch to any other application &#8211; they all respond normally. The IDE is completely unresponsive during the freeze, for example it does not repaint its windows. After the 50-second-freeze the IDE behaves fine for five minutes until it freezes again. This effect was seen on an installation of the demo version of Delphi 5.

As a first guess, I would turn off Delphi Direct. Do you have a permanent Internet connection? Maybe something is configured wrong and Delphi tries repeatedly to connect to www.Borland.com. You can turn off Delphi Direct in Tools | Environment Options

The freeze may occur because you have a bad directory in your (library) search path. Check all directories in your paths and make sure that all drives are actually mapped. The 50-second-freeze sounds like Windows tries to open a network connection. It could also be that a directory/ drive name points to a CD-ROM now and there is no CD in it or it contains a different CD than expected. Trim your paths to what is needed.

You may want to find out what is installed in your IDE that makes it searches your path periodically. I recommend de-activating as many packages as you can. This is done via Components | Packages.

The fact that it is a demo version should not be relevant. Good luck!

## 2005. április 23., szombat

### How to handle multiple, simultaneous key presses

Problem/Question/Abstract:

If I want to write a simple game where you can move and shoot at the same time, what would be the best way of handling the multiple key presses?

unit KeysForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;

type
TForm1 = class(TForm)
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Keys: array[Byte] of Boolean;

implementation

{\$R *.DFM}

procedure TForm1.Timer1Timer(Sender: TObject);
var
KeyNum, c: Integer;
begin
for KeyNum := 0 to 255 do
begin
c := Ord(Keys[KeyNum]) * 255;
Canvas.Pixels[KeyNum * 2, 10] := RGB(c, c, c);
Canvas.Pixels[KeyNum * 2 + 1, 10] := RGB(c, c, c);
Canvas.Pixels[KeyNum * 2 + 1, 11] := RGB(c, c, c);
Canvas.Pixels[KeyNum * 2, 11] := RGB(c, c, c);
end;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
Keys[Key] := True;
Key := 0;
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
Keys[Key] := False;
Key := 0;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
KeyNum: Integer;
begin
for KeyNum := 0 to 255 do
Keys[KeyNum] := False;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) then
Keys[VK_LBUTTON] := True
else if (Button = mbMiddle) then
Keys[VK_MBUTTON] := True
else if (Button = mbRight) then
Keys[VK_RBUTTON] := True;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) then
Keys[VK_LBUTTON] := False
else if (Button = mbMiddle) then
Keys[VK_MBUTTON] := False
else if (Button = mbRight) then
Keys[VK_RBUTTON] := False;
end;

end.

## 2005. április 22., péntek

### How to intercept a click on the forms' minimize button

Problem/Question/Abstract:

Does anybody know how to capture the minimize button press and act on it before it actually minimizes the form?

You should intercept WM_SYSCOMMAND messages like this:

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs;

type
TForm1 = class(TForm)
public
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then
MessageBeep(0);
DefaultHandler(Msg);
end;

end.

## 2005. április 21., csütörtök

### Credit Card Validation (2)

Problem/Question/Abstract:

How can I know if a number is a valid credit card number?

The following unit can be used to make credit card verification

unit Creditc;

{*****************************************************************************

Credit Card Number Validator Unit for Delphi

Version: 1.1
Date: December 20, 1996

This unit is based on the public domain program ccard by Peter Miller.
It is released to the public for free of charge use, but the author
reserves all rights.

copyright 1996 by Shawn Wilson Harvell ( shawn@inet.net )

usage:

validation function.

IsValidCreditCardNumber( CardNumber, ReturnMessage ) returns Boolean

for example, use it in an if statement that Messages user if invalid.

CardNumber is a string containing the number that you want to validate
ReturnMessage is a string where the function can place any messages it
may return ( meaning that it will overwrite whatever is in it )

returns true if valid, false otherwise.

dashes and space in the input value are taken care of by the function,
if other characters are possible, you may wish to remove them as well.
The function RemoveChar will take care of this quite easily, simply
pass the input string and the char you wish to delete.

Users are free to modify this unit for their own use, but in

Use this unit at your own risk, it does not come with any warranties
either express or implied. Damages resulting from the use of this
unit are the sole responsibility of the user.

This should work as is for Delphi versions 1 and 2, some slight
modifications may be necessary for Turbo Pascal ( mainly due to use to
conversion functions from the SysUtils unit ).

If you do find this useful, have any comments or suggestions, please
drop the author an email at shawn@inet.net

Revision History

version 1.1 -- December 20, 1996

version 1.0 -- October 26, 1996
initial release

*****************************************************************************}

interface

uses SysUtils;

function IsValidCreditCardNumber(CardNumber: string; var MessageText: string): Boolean;

implementation

const
CardPrefixes: array[1..19] of string =
('2014', '2149', '300', '301', '302',
'303', '304', '305', '34', '36', '37',
'38', '4', '51', '52', '53', '54', '55', '6011');

CardTypes: array[1..19] of string =
('enRoute',
'enRoute',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'American Express',
'Diner Club/Carte Blanche',
'American Express',
'Diner Club/Carte Blanche',
'Visa',
'MasterCard',
'MasterCard',
'MasterCard',
'MasterCard',
'MasterCard',
'Discover');

function RemoveChar(const Input: string; DeletedChar: Char): string;
var
Index: Word; { counter variable }
begin
{ all this function does is iterate through string looking for char, if found }
{ it deletes it }
Result := Input;
for Index := Length(Result) downto 1 do
if Result[Index] = DeletedChar then
Delete(Result, Index, 1);
end;

begin
{ simply a wrapper for this left bit shift operation }
result := (1 shl (Input - 12));
end;

function ConfirmChecksum(CardNumber: string): Boolean;
var
CheckSum: Integer; { Holds the value of the operation }
Flag: Boolean; { used to indicate when ready }
Counter: Integer; { index counter }
PartNumber: string; { used to extract each digit of number }
Number: Integer; { used to convert each digit to integer }
begin

{**************************************************************************
This is probably the most confusing part of the code you will see, I know
that it is some of the most confusing I have ever seen. Basically, this
function is extracting each digit of the number and subjecting it to the
checksum formula established by the credit card companies. It works from
the end to the front.
**************************************************************************}

{ get the starting value for our counter }
Counter := Length(CardNumber);
CheckSum := 0;
PartNumber := '';
Number := 0;
Flag := false;

while (Counter >= 1) do
begin
{ get the current digit }
PartNumber := Copy(CardNumber, Counter, 1);
Number := StrToInt(PartNumber); { convert to integer }
if (Flag) then { only do every other digit }
begin
Number := Number * 2;
if (Number >= 10) then
Number := Number - 9;
end;
CheckSum := CheckSum + Number;

Flag := not (Flag);

Counter := Counter - 1;
end;

result := ((CheckSum mod 10) = 0);
end;

begin
{ the default case }
result := 0;

if (CardName = 'MasterCard') then
if (CardName = 'Visa') then
if (CardName = 'American Express') then
if (CardName = 'Diner Club/Carte Blanche') then
if (CardName = 'Discover') then

end;

function IsValidCreditCardNumber(CardNumber: string; var MessageText: string):
Boolean;
var
StrippedNumber: string; { used to hold the number bereft of extra chars }
Index: Integer; { general purpose counter for loops, etc }
FoundIt: Boolean; { used to indicate when something is found }
CardName: string; { stores the name of the type of card }
PerformChecksum: Boolean; { the enRoute type of card doesn't get it }
begin

{ first, get rid of spaces, dashes }
StrippedNumber := RemoveChar(CardNumber, ' ');
StrippedNumber := RemoveChar(StrippedNumber, '-');

{ if the string was zero length, then OK too }
if (StrippedNumber = '') then
begin
result := true;
exit;
end;

{ initialize return variables }
MessageText := '';
result := true;

{ set our flag variable }
FoundIt := false;

{ check for invalid characters right off the bat }
for Index := 1 to Length(StrippedNumber) do
begin
case StrippedNumber[Index] of
'0'..'9': FoundIt := FoundIt; { non op in other words }
else
MessageText := 'Invalid Characters in Input';
result := false;
exit;
end;
end;

{ now let's determine what type of card it is }
for Index := 1 to 19 do
begin
if (Pos(CardPrefixes[Index], StrippedNumber) = 1) then
begin
{ we've found the right one }
FoundIt := true;
CardName := CardTypes[Index];
end;
end;

{ if we didn't find it, indicates things are already ary }
begin
CardName := 'Unknown Card Type';
MessageText := 'Unknown Card Type ';
result := false;
exit;
end;

{ check the length }
if ((Length(StrippedNumber) > 28) and result) then
begin
MessageText := 'Number is too long ';
result := false;
exit;
end;

{ check the length }
if ((Length(StrippedNumber) < 12) or
begin
messagetext := 'number length incorrect';
result := false;
exit;
end;

{ check the checksum computation }
if (cardname = 'enroute') then
performchecksum := false
else
performchecksum := true;

if (performchecksum and (not confirmchecksum(strippednumber))) then
begin
result := false;
exit;
end;

{ if result is still true, then everything is ok }
if (result) then
messagetext := 'number ok: card type: ' + cardname;

{ if the string was zero length, then ok too }
if (strippednumber = '') then
result := true;

end;

end.

## 2005. április 20., szerda

### Creating a system tray application

Problem/Question/Abstract:

How I can make my application not appear on the main display and but just in the system tray on startup?

You could use RxLib (freeware component collection) - it contains a component that does this. Drop the RxTrayIcon component on your main form and minimize/ hide your application with this code:

ShowWindow(Application.Handle, SW_HIDE);
Application.Minimize;

If using RxLib is not an option, then you can build it yourself with the ShellAPI function Shell_NotifyIcon(). Use the application from below as a starting point.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure Open1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ private declarations }
procedure WndProc(var Msg: TMessage); override;
public
{ public declarations }
IconData: TNotifyIconData;
IconCount: integer;
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

procedure TForm1.WndProc(var Msg: TMessage);
var
aPoint: TPoint;
begin
case Msg.Msg of
WM_USER + 1:
case Msg.lParam of
WM_RBUTTONDOWN:
begin
SetForegroundWindow(Handle);
GetCursorPos(aPoint);
PostMessage(Handle, WM_NULL, 0, 0);
end
end;
end;
inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
IconCount := 0;
IconData.cbSize := sizeof(IconData);
IconData.Wnd := Handle;
IconData.uID := 100;
IconData.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
IconData.uCallbackMessage := WM_USER + 1;
IconData.hIcon := Application.Icon.Handle;
StrPCopy(IconData.szTip, Application.Title);
end;

procedure TForm1.Open1Click(Sender: TObject);
begin
Form1.Show;
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @IconData);
Application.ProcessMessages;
Application.Terminate;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
Form1.Hide;
end;

begin
ShowWindow(Application.Handle, SW_HIDE);
end;

## 2005. április 19., kedd

Problem/Question/Abstract:

Introduction

The example

The following example illustrates how to retrieve data from the Northwind sample database included in SQL Server. We will create a business object that queries the database using ADO and generates an XML streams that is used by the client for data presentation/manipulation. On the client we will access this XML stream using a common ADO Recordset (I will use the TADODataset included in ADOExpress). Finally, when we are done modifiying the data we will convert the recordset in XML and send it back to the business object. Finally, this will update the database. All this will be done using SOAP. The XML that ADO generates is perfectly usable from any type client. A Java client could use it as well after converting it into a format it's more convenient.

How to install the sample

In my previous article DSOAP Toolkit I explained how you create a COM object and how you expose this to the world using the Microsoft SOAP SDK. In this article I will focus on the implementation of the business object. I will show how you can convert an ADO Recordset in XML and vice versa. I incuded the WSDL and WSML files in the zip so you will not need to recreate them. Download the example, register the ActiveX library DSOAPXMLLib.dll and move the WSDL and WSML files under c:\inetpub\wwwroot. When you are done with this, open the client application and test the webservice by pressing the "Get Customers" button. I assume your computer has SQL Server installed. If SQL Server is installed on a remote machine, modify the constant DBConnStr in the unit uCustomersDataObject_Impl.pas before registering the ActiveX library and launcing the client application. If you need to change the folder where the WSDL file will be contained, make sure you update the URL specified at the end of it top match the new directory.

The ActiveX library contains one COM object called CustomersDataObject. Its interface contains only two methods (GetCustomers and UpdateCustomers) as shown below:

GetCustomers is declared as:

function GetCustomers(const aFilter: WideString; out Errors: WideString): WideString;

The "aFilter" parameter takes a valid SQL WHERE condition such as "CustomerID line 'A%' " without the WHERE keyword. You will use this to filter the amount of data you want to receive. The method returns the XML generated by an ADO Recordset. UpdateCustomers is declared as:

function UpdateCustomers(const someChanges: WideString; out Errors: WideString):
WordBool;

The parameter someChanges takes the delta of changes that have been committed on the client and updates the database. It will return TRUE if succesful or FALSE if it failed. Notice the out parameter Errors in both methods. This is not required in order to handle error notification. As I explained in my other article Using SOAP with Delphi, the protocol defines a standard way to report errors. If an exception would be raise on the client, the Microsoft SOAP SDK would trap it and encode it in a SOAP error condition which would then be reraised client side. Sometimes I prefer to trap everything myself. By doing this you could log every error in a database table and have more control over things. Still, leaving the exception unhandled, is a valid approach as well.

Streaming a Recordset in XML

Streaming a Recordset in XML is a matter of calling the Recordset.Save method passing an object that implements IStream as parameter. You can use the ADO Stream or the XMLDOMDocument object for this porpouse. The second one is generally faster because it uses UTF8 encoding (1 byte character) and is optimized for XML processing. The ADO Stream instead works with UTF16 encoding (try saving both XML streams to a file and see the difference in size. I realized this thanks to the comments of Shiv Kumar. Have a look at his site at http://www.matlus.com In the unit uADOCommon.pas you will find the following function that, given a connection string and a SQL command, creates a Recordset and converts it into XML:

function SQLToXML(const aConnection: OleVariant; const aSQLCommand: string): string;
var
rs: _Recordset;
xml: IXMLDOMDocument2;
begin
// Creates a disconnected recordset that will be streamed into XML
rs := CoRecordset.Create;
rs.Set_ActiveConnection(nil);

// Streams _Recordset into XML
xml := CoDOMDocument30.Create;
rs.Close;

result := xml.xml;
end;

Pay special attention to the line in which I call the Recordset's Open method. I specified adOpenForwardOnly as cursor type. This has an immediate effect on performances while querying data from a SQL database. Generally speaking, the more flexible the cursor you open, the slower and more resource intensive it will be. Take a look at the article SQL Server Cursor library if you want to know more about the subject. Another important thing I did in the function above is to set the Recordset's connection to NIL and the CursorLocation to adUseClient. When using this combination of values you will generate a disconnected, client side Recordset. The resulting XML will look like this:

<xml xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882" xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882" xmlns:rs="urn:schemas-microsoft-com:rowset" xmlns:z="#RowsetSchema">
<s:Schema id="RowsetSchema">
<s:ElementType name="row" content="eltOnly" rs:updatable="true">
<s:AttributeType name="CustomerID" rs:number="1" rs:writeunknown="true" rs:basecatalog="Northwind" rs:basetable="CUSTOMERS" rs:basecolumn="CustomerID" rs:keycolumn="true">
<s:datatype dt:type="string" dt:maxLength="5" rs:fixedlength="true" rs:maybenull="false"/>
</s:AttributeType>
<s:AttributeType name="CompanyName" rs:number="2" rs:writeunknown="true" rs:basecatalog="Northwind" rs:basetable="CUSTOMERS" rs:basecolumn="CompanyName">
<s:datatype dt:type="string" dt:maxLength="40" rs:maybenull="false"/>
</s:AttributeType>
[..]

<s:extends type="rs:rowbase"/>
</s:ElementType>
</s:Schema>
<rs:data>
<z:row CustomerID="ALFKI" CompanyName="Alfreds Futterkiste" ContactName="Maria Anders" ContactTitle="Sales Representative" Address="Obere Str. 57" City="Berlin" PostalCode="12209" Country="Germany" Phone="030-0074321" Fax="030-0076545"/>
<z:row CustomerID="ANATR" CompanyName="Ana Trujillo Emparedados y helados" ContactName="Ana Trujillo" ContactTitle="Owner" Address="Avda. de la Constituci�n 2222" City="M�xico D.F." PostalCode="05021" Country="Mexico" Phone="(5) 555-4729" Fax="(5) 555-3745"/>
[..]

</rs:data>
</xml>

Make it a WebService

What you need to do now is to register your ActiveX library and generate the correct WSDL files using the Microsoft SOAP SDK like I explained in my previous article DSOAP Toolkit. I included the correct WSDL files in the example and the only thing you need to do is to copy them in the root c:\inetpub\wwwroot.

The client

So far so good. We know how to get our data, how to convert it in XML and how to stream it to the client. What we need now is to a way to invoke all this functionality from the client. By using the DSOAP WSDL Import Wizard specifying "http://localhost/DSOAPXMLLib.WSDL" as source, you will be able to generate the unit uCustomersDataObject_Impl.pas. See my other article for details. In order to make the example a little bit more interesting, I decided to show how to feed a TADODataset with this XML stream. By doing this, you will still be able to use all your third party data aware components like it were a regular MIDAS Clientdataset or a BDE TTable. From inside the Delphi IDE the client will look like this:

Receiving data

In order to receive data you need to invoke the GetCustomers method and ceonvert the XML back into a Recordset. The function XMLToRecordset contained in the common unit uADOCommon.pas takes care of this conversion and returns a Recordset. Once you have that, just assign it to the ADODataset by setting its Recordset property. The following code is execute when you press the "Get Customers" button:

procedure TForm1.bGetCustomersClick(Sender: TObject);
var
errs: widestring;
xml: string;
rs: OleVariant;
begin
xml := fCustomersDataObject.GetCustomers(eFilter.Text, errs);

[...]

[...]

end;

While this is the XMLToRecordset funtions' code:

function XMLToRecordset(const someXML: string): _Recordset;
var
xml: IXMLDOMDocument2;
rs: OleVariant;
begin
xml := CoDOMDocument30.Create;
rs := CoRecordset.Create;
rs.Open(xml);

result := IUnknown(rs) as _Recordset;
end;

By reversing what we did on the server side, we can feed the Recordset back with its rows. It almost cannot get simpler than this!

Sending updates back to the middle tier

Here's where it gets a little bit tricky, client side. The ADO Recordset keeps track of all the changes the user made to the original data we received. In order for us to update the database, we need to send these changes back by invoking the server side method UpdateCustomers. The problem we have now is that the XML stream generated client side will contain both the changes and the original data. This is extremely not efficient since the only thing the server needs are the updates. Take a look at the code associated to the button bUpdateCustomers:

procedure TForm1.bUpdateCustomersClick(Sender: TObject);
var
xml, errs: widestring;
begin
[..]

if not fCustomersDataObject.UpdateCustomers(xml, errs) then
MessageDlg(errs, mtError, [mbOK], 0)
else
begin
ShowMessage('Updated!');
end;
end;

I am generating XML using the function FilterUpdates. Here's the code:

var
DOMDoc: IXMLDOMDocument2;
RemNode, DataNode: IXMLDOMNode;
i, offset: integer;
begin
DOMDoc := CoDOMDocument30.Create;
DOMDoc.Async := FALSE;

DataNode := DOMDoc.selectSingleNode('xml/rs:data');
offset := 0;

for i := 0 to (DataNode.childNodes.length - 1) do
begin
if (DataNode.childNodes[i - offset].nodeName = 'z:row') then
begin
RemNode := DataNode.removeChild(DataNode.childNodes[i - offset]);
offset := offset + 1;
end;
end;

result := DOMDoc.xml
end;

This function was inspired by an article I found on the MSDN website. Take a look at it by clicking here. What I do here is nothing but filtering out all the original data while keeping the updates. This is how the XML stream will look after this operation:

<xml xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882" xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882" xmlns:rs="urn:schemas-microsoft-com:rowset" xmlns:z="#RowsetSchema">
<s:Schema id="RowsetSchema">
<s:ElementType name="row" content="eltOnly" rs:updatable="true">
<s:AttributeType name="CustomerID" rs:number="1" rs:writeunknown="true" rs:basecatalog="Northwind" rs:basetable="CUSTOMERS" rs:basecolumn="CustomerID" rs:keycolumn="true">
<s:datatype dt:type="string" dt:maxLength="5" rs:fixedlength="true" rs:maybenull="false"/>
</s:AttributeType>
[..]   <s:extends type="rs:rowbase"/>
</s:ElementType>
</s:Schema>
<rs:data>
<rs:update>
<rs:original>
<z:row CustomerID="WOLZA" CompanyName="Wolski  Zajazd" ContactName="Zbyszek Piestrzeniewicz" ContactTitle="Owner" Address="ul. Filtrowa 68" City="Warszawa" PostalCode="01-012" Country="Poland" Phone="(26) 642-7012" Fax="(26) 642-7012"/>
</rs:original>
<z:row CompanyName="Wolski  Zajazdxxx"/>
</rs:update>
<rs:insert>
<z:row CustomerID="A    " CompanyName="Test"/>
<z:row CustomerID="B    " CompanyName="Test #2"/>
</rs:insert>
</rs:data>
</xml>

The final step: updating the database

We are almost done. Now we sent the batch of updates back to the server using XML and we invoked the method UpdateCustomers. If you take a look at the code, you will find the following:

function TCustomersDataObject.UpdateCustomers(const someChanges: WideString; out
Errors: WideString): WordBool;
begin
result := FALSE;
Errors := '';
try

result := TRUE;
except
on E: Exception do
Errors := E.Message;
end;
end;

There's nothing particoular in that code except the call to the method UpdateSource listed below:

procedure UpdateSource(const aConnection: OleVariant; const someChanges: string);
var
rs, conn: OleVariant;
begin
rs := XMLToRecordset(someChanges);

case VarType(aConnection) of

varUnknown,
varDispatch: conn := IUnknown(aConnection) as _Connection;

else
begin
conn := CoConnection.Create;
conn.Open(aConnection, '', '', 0);
end;
end;

rs.ActiveConnection := conn;

rs.Close;
end;

We just converted the delta of changes into a Recordset and we finally used its UpdateBatch method to persist the changes to the database.

Conclusion

You can find more information about ADO on the Microsoft website. What you saw above should give you a pretty good idea of how updates work in a distributed, stateless environment and how you can use existing technologies to do this efficiently and in a very simple way.

## 2005. április 18., hétfő

### Show/Hide the "Start" button

Problem/Question/Abstract:

Show/Hide the "Start" button

Solve 1:

The following procedure hides or shows the start button:

procedure hideStartbutton(visi: boolean);
var
Tray,Child: HWnd;
c: array[0..127] of Char;
s: string;
begin { hideStartButton }
Tray := FindWindow('Shell_TrayWnd', nil);
Child := GetWindow(Tray, GW_CHILD);
while Child <> 0 do
begin
if GetClassName(Child, c, SizeOf(c)) > 0 then
begin
s := StrPas(c);
if UpperCase(s) = 'BUTTON' then
begin
// IsWindowVisible(Child)
startbutton_handle := Child;
if visi then
ShowWindow(Child, 1)
else
ShowWindow(Child, 0)
end
end;
Child := GetWindow(Child, GW_HWNDNEXT)
end
end; { hideStartButton }

Solve 2:

To show:

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), TRUE);

To hide:

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), FALSE);

## 2005. április 17., vasárnap

### Viewing Targa Bitmap File Format in Delphi (256-colors)

Problem/Question/Abstract:

How to view Bitmap in Targa File Format (*.tga) using Delphi ?

This is quite simple way to answer above question: viewing Targa file format using Delphi (not compress and limited only 256 colors).

Here is the example code:

const
FERRORMSG2 = 'Sorry, Unsupported Compressed(RLE) File Format';
FERRORMSG3 = 'Sorry, Unsupported More Than 256 Colours File Format';

type
TArrBuff = array[1..512] of Byte;
TPalette_Cell = record
b2, g2, r2: byte;
end;
TPal = array[0..255] of TPalette_Cell;
TPPal = ^TPal;
IDLength, ColorMap, ImageType: byte;
ClrMapSpes: array[1..5] of byte;
XAwal, YAwal, Width, Height: SmallInt;
BpPixel, ImageDescription: byte;
end;

var
pal: TPPal;
pFile: file;
buffer: TArrBuff;

var
i, j, idx: integer;
begin
begin
begin
idx := j - FtgaHeader.XAwal + 1;
SetPixel(Bitmap.Canvas.Handle, j, i, rgb(pal^[buffer[idx]].r2,
pal^[buffer[idx]].g2, pal^[buffer[idx]].b2));
end;
end;
end;

begin
AssignFile(pFile, FileName);
{\$I-}Reset(pFile, 1);
{\$I+}
if (IOResult = 0) then
begin
try
// checking unsupported features here
begin
MessageBox(Application.Handle, FERRORMSG2, 'TGA Viewer Error', MB_ICONHAND);
exit;
end;
begin
MessageBox(Application.Handle, FERRORMSG3, 'TGA Viewer Error', MB_ICONHAND);
exit;
end;
GetMem(pal, 768);
try
// if use Color-Map and Uncompressed then read it
finally
FreeMem(pal);
end;
finally
CloseFile(pFile);
end;
end
else
MessageBox(Application.Handle, 'Error Opening File', 'TGA Viewer Error',
MB_ICONHAND);
end;

How to try this code ?? Just call the "LoadFromFile" procedure above in your application (probably with little modification offcourse, especially about the name of mainForm that I used here [THPTGA]).

For full source code and simple application that use this, you can look and download from my website: www.geocities.com/h4ryp/delphi.html.

Note: At http://www.delphi-gems.com/Graphics.php you can download the freeware Delphi unit GraphicEx.pas which makes a bunch of graphics formats available to Delphi programs, among them PCX, TIFF, TGA, etc. The formats are embedded into Delphi in the same way as Borland's jpeg unit.

## 2005. április 16., szombat

### Auxiliary TQuery used with queries built at run time

Problem/Question/Abstract:

Auxiliary queries built at run time make you copy-paste a lot, replicating your code. Why not keep it to a minimum, making it easy to read and mantain ?

Do you have an auxiliary TQuery on your form that you use to build dynamic queries, like

'SELECT Count(id) FROM Clients'

and a bit latter you use the same TQuery to

'SELECT Count(Phone_numbers) FROM Clients WHERE area = '1''

and latter on you use it again to

'SELECT Count(area) FROM Contacts'

and so on...

If you have an auxiliar TQuery to run all these queries, you probably have a lot of similar code replicated in your application to load the query string, prepare the query, run the query and finally close the query.
Since replication is not a good thing when it comes to maintenance, why not abstract the queries from the code so that you just have to pass the TQuery object, the query string and, optionally, the database, if you use different databases.

Here's sometinh I've been using for a while that creates that abstraction layer:

procedure Execute(Q: TQuery; S: string; DBName = '');
begin
with Q do
begin
if DBName <> '' then
DatabaseName := DBName;
try
Close;
finally
SQL.Clear;
end;

try
Prepare;
while not (Prepared) do
;
Open;
finally
;
end;
end;
end;

Using this procedure, you can reduce the amount of code and maintenance effort to a minimum, since you can prepare and open the queries just by using:

Execute(MyTQuery, 'SELECT Count(id) FROM Clients');

Execute(MyTQuery, 'SELECT Count(Phone_numbers) FROM Clients WHERE area = ' 1 '');

Execute(MyTQuery, 'SELECT Count(area) FROM Contacts', 'Contacts_database');

Execute(MyTQuery, 'SELECT Count(ZIP) FROM Zip_Codes', 'Address_database');

Execute(MyTQuery, 'SELECT Names FROM Vip_Clients', 'clients_database');

After calling the Execute procedure, you are able to read the result from the TQuery as usual.
This procedure simplifies the process of checking if the object is opened, close it if necessary, prepare the query for execution, release the resources to other processes while not ready and finally run the query.

## 2005. április 15., péntek

### Have a menu in any form

Problem/Question/Abstract:

I need to display a menu in the expert's "main" form. Now this form was created with TForm1.Create() and therefore not an application's main window.

Although the menu is displayed in design mode properly, at runtime it will not appear. Even manually assigning the menu with  Menu := MainMenu   will not help.

Use the API function SetMenu in the FormCreate handler as shown below:

procedure TForm1.FormCreate(Sender: TObject);
var
h: integer;
begin
h := ClientHeight;
ClientHeight := h;
end;

## 2005. április 14., csütörtök

### Convert a RFC time string into TDateTime and VV

Problem/Question/Abstract:

How to convert a RFC time string into TDateTime and vv.

Conversion of date & time formats: RFC <-> TDateTime (local & UNC) RFC: e.g. 03.01.2001 05:45:00 -0500

TDateTime -> RFC use

DateTimeToRfcTime(date, diff, gmt)

RFC -> TDateTime  use

RfcTimeToDateTime(time, gmt)

function DateTimeToRfcTime(
dt: TDateTime;
iDiff: integer;
blnGMT: boolean = false): string;
{*
Explanation:
iDiff is the local offset to GMT in minutes
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -300 minutes
dt is TDateTime of 3 Jan 2001 5:45am
blnGMT = true  -> Result = 'Wed, 03 Jan 2001 05:45:00 GMT'
blnGMT = false -> Result = 'Wed, 03 Jan 2001 05:45:00 -0500'
*}
const
Weekday: array[1..7] of string =
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
Month: array[1..12] of string = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
var
iDummy: Word;
iYear: Word;
iMonth: Word;
iDay: Word;
iHour: Word;
iMinute: Word;
iSecond: Word;
strZone: string;
begin
if blnGMT then
begin
dt := dt - iDiff / 1440;
strZone := 'GMT';
end
else
begin
iDiff := (iDiff div 60) * 100 + (iDiff mod 60);
if iDiff < 0 then
strZone := Format('-%.4d', [-iDiff])
else
strZone := Format('+%.4d', [iDiff]);
end;
DecodeDate(dt, iYear, iMonth, iDay);
DecodeTime(dt, iHour, iMinute, iSecond, iDummy);
Result := Format('%s, %.2d %s %4d %.2d:%.2d:%.2d %s', [
Weekday[DayOfWeek(dt)], iDay, Month[iMonth], iYear,
iHour, iMinute, iSecond, strZone]);
end;

function RfcTimeToDateTime(
strTime: string;
blnGMT: boolean = true): TDateTime;
{*
Explanation:
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -0500
strTime = 'Wed, 03 Jan 2001 05:45:00 -0500'
blnGMT = true  -> FormatDateTime('...', Result) = '03.01.2001 10:45:00'
blnGMT = false -> FormatDateTime('...', Result) = '03.01.2001 05:45:00'
*}
const
wd = 'sun#mon#tue#wed#thu#fri#sat';
month = 'janfebmaraprmayjunjulaugsepoctnovdec';
var
s: string;
dd: Word;
mm: Word;
yy: Word;
hh: Word;
nn: Word;
ss: Word;
begin
s := LowerCase(Copy(strTime, 1, 3));
if Pos(s, wd) > 0 then
Delete(strTime, 1, Pos(' ', strTime));
s := Trim(Copy(strTime, 1, Pos(' ', strTime)));
Delete(strTime, 1, Length(s) + 1);
dd := StrToIntDef(s, 0);
s := LowerCase(Copy(strTime, 1, 3));
Delete(strTime, 1, 4);
mm := (Pos(s, month) div 3) + 1;
s := Copy(strTime, 1, 4);
Delete(strTime, 1, 5);
yy := StrToIntDef(s, 0);
Result := EncodeDate(yy, mm, dd);
s := strTime[1] + strTime[2];
hh := StrToIntDef(strTime[1] + strTime[2], 0);
nn := StrToIntDef(strTime[4] + strTime[5], 0);
ss := StrToIntDef(strTime[7] + strTime[8], 0);
Delete(strTime, 1, 9);
Result := Result + EncodeTime(hh, nn, ss, 0);
if (CompareText(strTime, 'gmt') <> 0) and blnGMT then
begin
hh := StrToIntDef(strTime[2] + strTime[3], 0);
nn := StrToIntDef(strTime[4] + strTime[5], 0);
if strTime[1] = '+' then
Result := Result - EncodeTime(hh, nn, 0, 0)
else
Result := Result + EncodeTime(hh, nn, 0, 0);
end;
end;

## 2005. április 13., szerda

### Determine the default browser

Problem/Question/Abstract:

This article describes how to determine the default browser and its version

The WinAPI provides an excellent function for this purpose: FindExecutable. This function returns the application associated with the given file. The application associated with a .htm file is the default browser.
The prototype is

function FindExecutable(FileName, Directory: PChar; Result: PChar): HINST;

Unfortunately this function needs an existent file. For this reason it is necessary to create a temporary one.

Basic function

The basic function performs the following steps:

Determine the temp directory
Create a file with ".htm" extension.
Use FindExecutable
Delete the temporary file

type
TBrowserInformation = record
Name: string;
Path: string;
Version: string;
end;

function GetDefaultBrowser: TBrowserInformation;
var
tmp: PChar;
res: PChar;

begin
tmp := StrAlloc(255);
res := StrAlloc(255);

try
GetTempPath(255, tmp);
FileCreate(tmp + 'htmpl.htm');
FindExecutable('htmpl.htm', tmp, Res);
Result.Name := ExtractFileName(res);
Result.Path := ExtractFilePath(res);
SysUtils.DeleteFile(tmp + 'htmpl.htm');
finally
StrDispose(tmp);
StrDispose(res);
end;
end;

Long File Name

Now, if you run that function you will notice that there is a small inconvenience: The function returns the location of the default browser as short path. The next function will try to convert it to the long format.

function LongPathName(ShortPathName: string): string;
var
PIDL: PItemIDList;
Desktop: IShellFolder;
WidePathName: WideString;
AnsiPathName: AnsiString;
begin
Result := ShortPathName;
if Succeeded(SHGetDesktopFolder(Desktop)) then
begin
WidePathName := ShortPathName;
if Succeeded(Desktop.ParseDisplayName(0, nil, PWideChar(WidePathName), ULONG(nil^), PIDL, ULONG(nil^))) then
try
SetLength(AnsiPathName, MAX_PATH);
SHGetPathFromIDList(PIDL, PChar(AnsiPathName));
Result := PChar(AnsiPathName);
end;
end;
end;

Version Information

The next step is to extend the basic function with error handling and the ability to get the default browsers version.

function GetDefaultBrowser: TBrowserInformation;
var
tmp: PChar;
res: PChar;
Version: Pointer;
VersionInformation: Pointer;
VersionInformationSize: Integer;
Dummy: Integer;

begin
tmp := StrAlloc(255);
res := StrAlloc(255);

Version := nil;

try
GetTempPath(255, tmp);

if FileCreate(tmp + 'htmpl.htm') <> -1 then
begin
if FindExecutable('htmpl.htm', tmp, res) > 32 then
begin
Result.Name := ExtractFileName(res);
Result.Path := LongPathName(ExtractFilePath(res));

// Try to determine the Browser Version

VersionInformationSize := GetFileVersionInfoSize(Res, Dummy);

if VersionInformationSize > 0 then
begin
GetMem(VersionInformation, VersionInformationSize);
GetFileVersionInfo(Res, 0, VersionInformationSize, VersionInformation);

VerQueryValue(VersionInformation, ('StringFileInfo040904E4ProductVersion'),
Pointer(Version), Dummy);

if Version <> nil then
Result.Version := PChar(Version);

FreeMem(VersionInformation);
end;
end
else
raise EGetDefaultBrowser.Create('Can''t determine the executable.');

SysUtils.DeleteFile(tmp + 'htmpl.htm');
end
else
raise EGetDefaultBrowser.Create('Can''t create temporary file.');

finally
StrDispose(tmp);
StrDispose(res);
end;
end;

## 2005. április 12., kedd

### How to highlight a TBitmap with a color overlay

Problem/Question/Abstract:

Does anyone know of a way that I can achieve the same effect on a bitmap that Windows achieves when you single click on an icon on the desktop? In other words, I want to "highlight" a bitmap and let the user know that it is selected.

To me it appears as if the icons on my desktop are highlighted by overlaying them with a certain color, so I guess the following routine is of use.

procedure Highlight(aSource, ATarget: TBitmap; AColor: TColor);
{Alters ASource to ATarget by making it appear as if looked through colored glass as given by AColor.
ASource, ATarget must have been created. Isn't as slow as it looks. Physics courtesy of a post by K.H. Brenner}
var
i, j: Integer;
s, t: pRGBTriple;
r, g, b: byte;
cl: TColor;
begin
cl := ColorToRGB(AColor);
r := GetRValue(cl);
g := GetGValue(cl);
b := GetBValue(cl);
aSource.PixelFormat := pf24bit;
ATarget.PixelFormat := pf24bit;
ATarget.Width := aSource.Width;
ATarget.Height := aSource.Height;
for i := 0 to aSource.Height - 1 do
begin
s := ASource.Scanline[i];
t := ATarget.Scanline[i];
for j := 0 to aSource.Width - 1 do
begin
t^.rgbtBlue := (b * s^.rgbtBlue) div 255;
t^.rgbtGreen := (g * s^.rgbtGreen) div 255;
t^.rgbtRed := (r * s^.rgbtRed) div 255;
inc(s);
inc(t);
end;
end;
end;

## 2005. április 11., hétfő

### Getting a lot of files in one stream

Problem/Question/Abstract:

How to get a lot of files in one stream
And get it back to :)

Some times i want to Have multiple files in a stream couse then i dont have to send a lot of files but just one .

So heres a little code sniped to get it in and out again.

procedure TForm1.ThisISHowIPutFilesIn;
var
ABigFileStream, SomeSmallFiles: TMemoryStream;

begin
ABigFileStream := TMemoryStream.Create;
try
SomeSmallFiles := TMemoryStream.Create;
try
// enz
finally
SomeSmallFiles.Free;
end;
ABigFileStream.SaveToFile('C:\MrBig.DDD')
finally
ABigFileStream.free;
end;
end;

procedure TForm1.ThisISHowIGetStufOut;
var
ABigFileStream, SomeSmallFiles: TMemoryStream;

begin
ABigFileStream := TMemoryStream.Create;
try
SomeSmallFiles := TMemoryStream.Create;
try
GetFromStream(ABigFileStream, SomeSmallFiles, 0);
SomeSmallFiles.SaveToFile('C:\SomeSmalFile1.txt');
GetFromStream(ABigFileStream, SomeSmallFiles, 1);
SomeSmallFiles.SaveToFile('C:\SomeSmalFile2.txt');
// enz
finally
SomeSmallFiles.Free;
end;
finally
ABigFileStream.free;
end;
end;

var
Size: Integer;
begin
Source.position := 0;
// Keep the size by puting it in the first byte
Size := Source.Size;
Dest.Write(Size, SizeOf(Integer));
Dest.CopyFrom(Source, Source.size);
end;

procedure TForm1.GetFromStream(Source, Dest: TStream; Index: Integer);
var
Size, I: Integer;

begin
Source.Position := 0;
for i := 0 to index - 1 do
begin
Source.Position := Source.Position + Size;
end;
// if where all the way up the file pointer then someting went wrong :(
if Source.position = Source.Size then
raise EAccessViolation.Create('Index Out Of Bounds');
// Get the desired file size
// Clear Dest Buffer
Dest.Position := 0;
Dest.Size := 0;
Dest.CopyFrom(Source, Size);
end;

## 2005. április 10., vasárnap

Problem/Question/Abstract:

How can you get the computers MAC address?

Solve 1:

The following code will allow you to retrieve the MAC address of your computer. It is a close translation of the C++ code found at the Borland Community at:
http://community.borland.com/article/0,1410,26040,00.html

You must include the NB30 unit in your uses clause for this code to work.

uses
NB30;

var
NCB: TNCB;
begin
FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBRESET);
NCB.ncb_lana_num := Lana;
if Netbios(@NCB) <> Char(NRC_GOODRET) then
begin
Exit;
end;

FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBASTAT);
NCB.ncb_lana_num := Lana;
NCB.ncb_callname := '*';

if Netbios(@NCB) <> Char(NRC_GOODRET) then
begin
Exit;
end;
Result :=
end;

var
NCB: TNCB;
begin
FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBENUM);
Netbios(@NCB);
else
end;

Solve 2:

// Here is a function that we use to get the MAC address.
// It comes from the CoCreateGUID API call.  In W2K
// Microsoft changed the underlying call in CoCreateGUID
// to a random value instead of the MAC address that is
// why the function checks which version of Windows is
// running and then makes the appropriate API call.
type
TGUID = record
A, B: word;
D, M, S: word;
MAC: array[1..6] of byte;
end;
var
UuidCreateFunc: function(var guid: TGUID): HResult; stdcall;
handle: THandle;
g: TGUID;
WinVer: _OSVersionInfoA;
i: integer;
ErrCode: HResult;
begin
WinVer.dwOSVersionInfoSize := sizeof(WinVer);
getversionex(WinVer);

if WinVer.dwMajorVersion >= 5 then {Windows 2000 }
else

UuidCreateFunc(g);
result := '';
for i := 1 to 6 do
result := result + IntToHex(g.MAC[i], 2);
end;

## 2005. április 9., szombat

### How to get a list of all table names in a database

Problem/Question/Abstract:

How does one get a list of the table names in a database? The TDatabase.Datasets list seems to be only open tables. I need to get at the unopened ones as well.

procedure TForm1.Button1Click(Sender: TObject);
var
ts: TStringlist;
begin
ts := TStringlist.create;
Session.GetTableNames('DBDEMOS', '*.DB', false, false, ts);
listbox1.items.assign(ts);
ts.free;
end;

## 2005. április 8., péntek

### Updating a table with data from another table with Local SQL

Problem/Question/Abstract:

The UPDATE sentence of Local SQL (the SQL used by the BDE) doesn't support JOIN... How two update a table with data from another table?

Orders.db

Customer.db
CustNo
<<--------->
CustNo

Assuming that we wanted to update the fields ShipToAddr1 and ShipToAddr2 of the Orders.db table with the values of the fields Addr1 and Addr2 respectively from the table Customer.db, for those records of Orders that have both fields blank, and joining the tables by the field CustNo present in both tables, perhaps we would be temped to write:

UPDATE Orders INNER JOIN Customer
ON Customer.CustNo = Orders.CustNo

However, in Local SQL (the one used by the BDE), joins are not supported in the UPDATE statement, and we have to use subqueries to achieve the expected result:

UPDATE Orders
Customer.CustNo = Orders.CustNo),
Customer.CustNo = Orders.CustNo)

In the "UPDATE statement" topic of the Local SQL Guide you can find an example of a 1-to-many relationship that uses grouping the subqueries.

Copyright (c) 2001 Ernesto De Spirito

## 2005. április 7., csütörtök

### Basic authentication in ISAPI/CGI applications

Problem/Question/Abstract:

How to password protect ISAPI/CGI actions with basic authentication?

It is very easy to protect a web server virtual directory with basic authentication.
Supose you have an ISAPI application with 3 actions and you want to password protect only one of them. This example shows you how you could do that with only one ISAPI application.

Source Code:

- This 2 lines tells browser to prompt for user name and password:

Response.StatusCode := 401; // Promp for user name and password
Response.WWWAuthenticate := 'Basic realm="Delphi"'; // Title

- Browser sends user name and password and we can get it:

Request.Authorization

- But information is encoded with Base64. There a lot of free source code that implements Base64 encode/decode. The following line returns decoded data in mAuthorization.

FBase64.DecodeData(Copy(Request.Authorization, 6, Length(Request.Authorization)),
mAuthorization);

## 2005. április 6., szerda

### How to animate a window while opening a form

Problem/Question/Abstract:

How to animate a window while opening a form

This project uses two forms:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
procedure FormClick(Sender: TObject);
private
procedure FocusAnimation(DC: HDC; AnimRect: TRect; Steps, Speed, Direction: Integer);
public
end;

const
FA_IN = 0;
FA_OUT = 1;

var
Form1: TForm1;

implementation

uses Unit2;

{\$R *.DFM}

procedure TForm1.FormClick(Sender: TObject);
var
WRect: TRect;
begin
GetWindowRect(Form2.handle, WRect);
FocusAnimation(GetDC(0), WRect, 20, 10, FA_OUT);
{Open form2}
Form2.ShowModal;
end;

procedure TForm1.FocusAnimation(DC: HDC; AnimRect: TRect; Steps, Speed, Direction: Integer);
var
cv, animx, animy, animwidth, animheight: Integer;
xp, yp: Double;
FRect: TRect;
cancel: Boolean;
begin
{Steps = number of steps during open/close operation,
Speed = time between the steps,
Direction = inner/outer direction}
animx := AnimRect.left + (AnimRect.right - AnimRect.left) div 2;
animy := AnimRect.top + (AnimRect.bottom - AnimRect.top) div 2;
animwidth := AnimRect.right - AnimRect.left;
animheight := AnimRect.bottom - AnimRect.top;
xp := animwidth div 2 / Steps; {horizontal}
yp := animheight div 2 / Steps; {vertical}
if Direction = FA_OUT then
cv := 0
else
cv := Steps;
while not cancel do
begin
FRect := Rect(Round(animx - cv * xp), Round(animy - cv * yp),
Round(animx + cv * xp), Round(animy + cv * yp));
DrawFocusRect(DC, FRect);
Sleep(Speed);
DrawFocusRect(DC, FRect);
if Direction = FA_OUT then
begin
Inc(cv);
if cv > Steps then
cancel := True;
end
else
begin
Dec(cv);
if cv < 0 then
cancel := True;
end;
end;
end;

end.

## 2005. április 5., kedd

### Creating threads straight from the WinAPI

Problem/Question/Abstract:

How can I implement threads in my programs without using the VCL TThread object?

I've done extensive work in multi-threaded applications. And in my experience, there have been times when a particular program I'm writing should be written as a multi-threaded application, but using the TThread object just seems like overkill. For instance, I write a lot of single function programs; that is, the entire functionality (beside the user interface portion) of the program is contained in one single execution procedure or function. Usually, this procedure contains a looping mechanism (e.g. FOR, WHILE, REPEAT) that operates on a table or an incredibly large text file (for me, that's on the order of 500MB-plus!). Since it's just a single procedure, using a TThread is just too much work for my preferences.

For those experienced Delphi programmers, you know what happens to the user interface when you run a procedure with a loop in it: The application stops receiving messages. The most simple way of dealing with this situation is to make a call to Application.ProcessMessages within the body of the loop so that the application can still receive messages from external sources. And in many, if not most, cases, this is a perfectly valid thing to do. However, if some or perhaps even one of the steps within the loop take more than a couple of seconds to complete processing &#8212; as in the case of a query &#8212; Application.ProcessMessages is practically useless because the application will only receive messages at the time the call is made. So what you ultimately achieve is intermittent response at best. Using a thread, on the other hand, frees up the interface because the process is running completely separate from the main thread of the program where the interface resides. So regardless of what you execute within a loop that is running in a separate thread, your interface will never get locked up.

I mentioned above that the TThread object is overkill for really simple threaded stuff. This is strictly an opinion, but experience has made me lean that way. In any case, what is the alternative to TThread in Delphi?

The solution isn't so much an alternative as it is going a bit more low-level into the Windows API. I've said this several times before: The VCL is essentially one giant wrapper around the Windows API and all its complexities. But fortunately for us, Delphi provides a very easy way to access lower-level functionality beyond the wrapper interface with which it comes. And even more fortunate for us, we can create threads using a simple Windows API function called CreateThread to bypass the TThread object altogether. As you'll see below, creating threads in this fashion is incredibly easy to do.

Setting Yourself Up

There are two distinct steps for creating a thread: 1)Create the thread itself, then 2) Provide a function that will act as the thread entry point. The thread function or thread entry point is the function (actually the address of the function) that tells your thread where to start.

Unlike a regular function, there are some specific requirements regarding the thread function that you have to obey:

You can give the function any name you want, but it must be a function name (ie. function MyThreadFunc)
The function must have a single formal parameter of type Pointer (I'll discuss this below)
The function return type is always LongInt
Its declaration must always be preceded by the stdcall directive. This tells the compiler that the function will be passing parameters in the standard Windows convention.

Whew! That seems like a lot but it's really not as complicated as it might seem from the description above. Here's an example declaration:

That's it! Hope I didn't get you worried. The CreateThread call is a bit more involved, but it too is not very complicated once you understand how to call it. Here's its declaration, straight out of the help file:

lpParameter: Pointer; //Input parameter for the thread
dwCreationFlags: DWORD; //Creation flags
THandle; stdcall; //Function returns a handle to the thread

This is not as complicated as it seems. First of all, you rarely have to set security attributes, so that can be set to nil. Secondly, in most cases, your stack size can be 0 (actually, I've never found an instance where I have to set this to a value higher than zero). You can optionally pass a parameter through the lpParameter argument as a pointer to a structure or address of a variable, but I've usually opted to use global variables instead (I know, this breaking a cardinal rule of structured programming, but it sure eases things). Lastly, I've rarely had to set creation flags unless I want my thread to start in a suspended state so I can do some preprocessing. For the most part, I set this value as zero.

Now that I've thoroughly confused you, let's look at an example function that creates a thread:

procedure TForm1.Button1Click(Sender: TObject);
var
thr: THandle;
thrID: DWORD;
begin
FldName := ListBox1.Items[ListBox1.ItemIndex];
thr := CreateThread(nil, 0, @CreateRecID, nil, 0, thrID);
if (thr = 0) then
end;

Embarrassingly simple, right? It is. To make the thread in the function above, I declared two variables, thr and thrID, which stand for the handle of the thread and its identifier, respectively. I set a global variable that the thread function will access immediately before the call to CreateThread, then make the declaration, assigning the return value of the function to thr and inputting the address of my thread function, and the thread ID variable. The rest of the parameters I set to nil or 0. Not much to it.

Notice that the procedure that actually makes the call is an OnClick handler for a button on a form. You can pretty much create a thread anywhere in your code as long as you set up properly. Here's the entire unit code for my program; you can use it for a template. This program is actually fairly simple. It adds an incremental numeric key value to a table called RecID, based on the record number (which makes things really easy). Browse the code; we'll discuss it below:

unit main;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs, DB, DBTables, StdCtrls, ComCtrls,
Buttons;

type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
OpenDialog1: TOpenDialog;
SpeedButton1: TSpeedButton;
Label2: TLabel;
StatusBar1: TStatusBar;
Button1: TButton;
ListBox1: TListBox;
procedure SpeedButton1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
end;

var
Form1: TForm1;
TblName: string;
FldName: string;

implementation

{\$R *.DFM}

function CreateRecID(P: Pointer): LongInt; stdcall;
var
tbl: TTable;
I: Integer;
ses: TSession;
msg: string;
begin
Randomize; //Initialize random number generator
I := 0;
{Disable the Execute button so another thread can't be executed
while this one is running}
EnableWindow(Form1.Button1.Handle, False);

{If you're going to access any data in a thread, you have to create a
separate }
ses := TSession.Create(Application);
ses.SessionName := 'MyRHSRecIDSession' + IntToStr(Random(1000));

tbl := TTable.Create(Application);
with tbl do
begin
Active := False;
SessionName := ses.SessionName;
DatabaseName := ExtractFilePath(TblName); //TblName is a global variable set
TableName := ExtractFileName(TblName); //in the SpeedButton's OnClick handler
Open;
First;
try
{Start looping structure}
while not EOF do
begin
if (State <> dsEdit) then
Edit;
msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount);
{Display message in status bar}
SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
FieldByName(FldName).AsInteger := RecNo;
Next;
end;
finally
Free;
ses.Free;
EnableWindow(Form1.Button1.Handle, True);
end;
end;
msg := 'Operation Complete!';
SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
tbl: TTable;
I: Integer;
begin
with OpenDialog1 do
if Execute then
begin
Edit1.Text := FileName;
TblName := FileName;
tbl := TTable.Create(Application);
with tbl do
begin
Active := False;
DatabaseName := ExtractFilePath(TblName);
TableName := ExtractFileName(TblName);
Open;
LockWindowUpdate(Self.Handle);
for I := 0 to FieldCount - 1 do
begin
end;
LockWindowUpdate(0);
Free;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
thr: THandle;
thrID: DWORD;
begin
FldName := ListBox1.Items[ListBox1.ItemIndex];
thr := CreateThread(nil, 0, @CreateRecID, nil, 0, thrID);
if (thr = 0) then
end;

end.

The most important function here, obviously, is the thread function, CreateRecID. Let's take a look at it:

function CreateRecID(P: Pointer): LongInt; stdcall;
var
tbl: TTable;
I: Integer;
ses: TSession;
msg: string;
begin
Randomize; //Initialize random number generator
I := 0;
{Disable the Execute button so another thread can't be executed
while this one is running}
EnableWindow(Form1.Button1.Handle, False);

{If you're going to access any data in a thread, you have to create a
separate }
ses := TSession.Create(Application);
ses.SessionName := 'MyRHSRecIDSession' + IntToStr(Random(1000));

tbl := TTable.Create(Application);
with tbl do
begin
Active := False;
SessionName := ses.SessionName;
DatabaseName := ExtractFilePath(TblName); //TblName is a global variable set
TableName := ExtractFileName(TblName); //in the SpeedButton's OnClick handler
Open;
First;
try
{Start looping structure}
while not EOF do
begin
if (State <> dsEdit) then
Edit;
msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount);
{Display message in status bar}
SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
FieldByName(FldName).AsInteger := RecNo;
Next;
end;
finally
Free;
ses.Free;
EnableWindow(Form1.Button1.Handle, True);
end;
end;
msg := 'Operation Complete!';
SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
end;

This is a pretty basic function. I'll leave it up to you to follow the flow of execution. However, let's look at some very interesting things that are happening in the thread function.

First of all, notice that I created a TSession object before I created the table I was going to access. This is to ensure that the program will behave itself with the BDE. This is required any time you access a table or other data source from within the context of a thread. I've explained this in more detail in another article called How Can I Run Queries in Threads? Directly above that, I made a call to the Windows API function EnableWindow to disable the button that executes the code. I had to do this because since the VCL is not thread-safe, there's no guarantee I'd be able to successfully access the button's Enabled property safely. So I had to disable it using the Windows API call that performs enabling and disabling of controls.

Moving on, notice how I update the caption of a status bar that's on the bottom of the my form. First, I set the value of a text variable to the message I want displayed:

msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount);

Then I do a SendMessage, sending the WM_SETTEXT message to the status bar:

SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));

SendMessage will send a message directly to a control and bypass the window procedure of the form that owns it.

Why did I go to all this trouble? For the very same reason that I used EnableWindow for the button that creates the thread. But unfortunately, unlike the single call to EnableWindow, there's no other way to set the text of a control other than sending it the WM_SETTEXT message.

The point to all this sneaking behind the VCL is that for the most part, it's not safe to access VCL properties or procedures in threads. In fact, the objects that are particularly dangerous to access from threads are those descended from TComponent. These comprise a large part of the VCL, so in cases where you have to perform some interaction with them from a thread, you'll have to use a roundabout method. But as you can see from the code above, it's not all that difficult.

Of the thousands of functions in the Windows API, CreateThread is one of the most simple and straightforward. I spent a lot of time explaining things here, but there's a lot of ground I didn't cover. Use this example as a template for your thread exploration. Once you get the hang of it, you'll use threads in practically everything you do.