## 2009. október 31., szombat

### How to draw a rotated ellipse at a specific angle (2)

Problem/Question/Abstract:

I created an object based off of TGraphicControl and I used the TCanvas.Ellipse method to create an ellipse. I would like to give the user the ability to rotate this ellipse. I would also like to give the user the ability after rotating the ellipse to still adjust the size and shape.

You can use Win32GDI Routines. It works like this:

procedure RotatedEllipse(aCanvas: TCanvas; X1, Y1, X2, Y2: Integer);
var
T, O: TXForm; {in unit Windows}
begin
{ ... }
GetWorldTransform(aCanvas.Handle, O);
{Angle in degree}
T.eM11 := 1 * Cos(w / 360 * Pi * 2);
T.eM22 := 1 * Cos(w / 360 * Pi * 2);
T.eM12 := 1 * Sin(w / 360 * Pi * 2);
T.eM21 := 1 * -Sin(w / 360 * Pi * 2);
T.eDX := Round((X1 + X2) / 2);
T.eDY := Round((Y1 + Y2) / 2);
ModifyWorldTransform(aCanvas.Handle, T, MWT_LEFTMULTIPLY);
Canvas.Ellipse(X1, Y1, X2, Y2);
SetWorldTransform(TheDraw.Handle, O);
end;

## 2009. október 30., péntek

### Define variables in a Word document and set their values programmatically

Problem/Question/Abstract:

I need to define some variables in a Word document and be able to set their values from my Delphi program. How can I do that?

You can do that using custom document properties:

uses
Office97; {or Office2000, OfficeXP, Office_TLB}

var
VDoc, PropName, DocName: OleVariant;
VDoc := Word.ActiveDocument;
{ ... }

{ Set a document property }
PropName := 'MyOpinionOfThisDocument';
'Utter drivel', EmptyParam);
{ Read a document property }
Caption := VDoc.CustomDocumentProperties[PropName].Value;
{ ... }

## 2009. október 29., csütörtök

### Faster recordcount for sqlserver clientserver applications

Problem/Question/Abstract:

When using the standard dataset.recordcount in my client-server (win nt against sqlserver7 db, targettable has 500.000 records) i can go for lunch and stil be waiting (:-

For those of you who don't know why u should not use the standard dataset.recordcount when developing client server database applications.

since the standard dataset.recordcount iterates from begin of the table through the end of the table to result in the recordcount. This is a crime when developing cs db apps (against sqlserver7).

simply use another way of obtaining the number of records. I use a sql for obtaining the number of records in a sqlserver table.

drop a tquery on the form

provide this tquery with the follow SQL:

SQL:

select distinct max(itbl.rows)
from sysindexes as itbl
inner join sysobjects as otbl on (itbl.id = otbl.id)
where (otbl.type = 'U') and (otbl.name = :parTableName)

notice the parameter: parTableName type string

use this tquery to find out how many rows in the table

TIP: try to make your own tYourSqlServerCountQuery and thus override the recordcount property.
ByTheWay: use this only for sqlserver

for other cs db apps simply use a count sql (coming upnext time...)

## 2009. október 28., szerda

### Set system date and time

Problem/Question/Abstract:

Set system date and time

With the procedure SetDateTime you can set the date and time of the operating system, from within your Delphi application.

In the interface-section you define the procedure:

procedure SetDateTime(Year, Month, Day, Hour, Minu, Sec, MSec: Word);

In the 'implementation' you write...:

{ SetDateTime sets the date and time of the operating system }

procedure SetDateTime(Year, Month, Day, Hour, Minu, Sec, MSec: Word);
var
NewDateTime: TSystemTime;
begin
FillChar(NewDateTime, sizeof(NewDateTime), #0);
NewDateTime.wYear := Year;
NewDateTime.wMonth := Month;
NewDateTime.wDay := Day;
NewDateTime.wHour := Hour;
NewDateTime.wMinute := Minu;
NewDateTime.wSecond := Sec;
NewDateTime.wMilliseconds := MSec;
SetLocalTime(NewDateTime);
end;

## 2009. október 27., kedd

### Determining the associated application

Problem/Question/Abstract:

How can I get the application associated with a document?

Where is that information?

The applications associated with the file extensions are stored in the Windows Registry. To get this information first we should retrieve the "class" that a file extensions belongs to. This information can be found at:

HKEY_CLASSES_ROOT\.ext\(default)

where ".ext" is the file extension you want (like ".txt", ".bmp", etc.). Then we get the command line used to open that kind of files. To do that, we retrieve the data under

HKEY_CLASSES_ROOT\class\Shell\Open\Command\(default)

where "class" is the file class an extension belongs to. That string usually has the form

"D:\PATH\APPNAME.EXT" "%1" -OPTIONS

where %1 is a placeholder for the document file to open with the application, so we should find its position within the string and replace it with the filename we want to open.

Example

The following function returns the command line of the associated application to open a documente file:

function GetAssociation(const DocFileName: string): string;
var
FileClass: string;
Reg: TRegistry;
begin
Result := '';
Reg := TRegistry.Create(KEY_EXECUTE);
Reg.RootKey := HKEY_CLASSES_ROOT;
FileClass := '';
begin
Reg.CloseKey;
end;
if FileClass <> '' then
begin
begin
Reg.CloseKey;
end;
end;
Reg.Free;
end;

Copyright (c) 2001 Ernesto De Spirito

## 2009. október 26., hétfő

### Clear all edit controls on your form

Problem/Question/Abstract:

Clear all edit controls on your form

The shortest way to do this:

procedure TForm1.ClearAll;
var
i: integer;
begin
for i := 0 to ComponentCount - 1 do
if (Components[i] is TEdit) then
(Components[i] as TEdit).Text := '';
end;

## 2009. október 25., vasárnap

### BDE alias info

Problem/Question/Abstract:

BDE alias info

The following function uses the GetAliasParams method of TSession to get the directory mapping for an alias:

uses DbiProcs, DBiTypes;

function GetDataBaseDir(const Alias: string): string;
{* Will return the directory of the database given the alias
(without trailing backslash) *}
var
sp: PChar;
Res: pDBDesc;
begin
try
New(Res);
sp := StrAlloc(length(Alias) + 1);
StrPCopy(sp, Alias);
if DbiGetDatabaseDesc(sp, Res) = 0 then
Result := StrPas(Res^.szPhyName)
else
Result := '';
finally
StrDispose(sp);
Dispose(Res);
end;
end;

## 2009. október 24., szombat

### DBGrid Component that show deleted and updated and inserted new records in diffrent colors

Problem/Question/Abstract:

DBGrid Show all state of the related DataSet

This component show state of the related data set of DBGrid and used for data base controlers. It's appreciate to send any note or comment or suggestion to Vafaeija@yahoo.com

unit atcDBGrid;
{*
(c) Aveen Tech
2001 - 2002

FileName: atcDBGrid.pas

Version       Date            Author             Comment
1.0           13/06/2000      Majid Vafai Jahan  Create.

OVERVIEW
- This grid is inherited from DBGrid and add some required functionality to it.

Functionality:
- Record type are all records that may be modified, unmodified, inserted, deleted.
- Coloring according to Record type.
- show selected Record Type.

*}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, DBGrids, dbTables, db;
const
AlignFlags: array[TAlignment] of Integer =
(DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
RTL: array[Boolean] of Integer = (0, DT_RTLREADING);
type
TCachedShow = (csModify, csUnModify, csRemoved, csInserted, csAll, csNormal);
TatcDBGrid = class(TDBGrid)
private
FCachedShow: TCachedShow;
FModifiedColor: TColor;
FInsertedColor: TColor;
FDeletedColor: TColor;
procedure SetCachedShow(const Value: TCachedShow);
protected
procedure DrawDataCell(const Rect: TRect; Field: TField;
State: TGridDrawState); override;
procedure DrawColumnCell(const Rect: TRect; DataCol: Integer;
Column: TColumn; State: TGridDrawState); override;
public
constructor Create(AOwner: TComponent); override;
published
property atcCachedShow: TCachedShow read FCachedShow write SetCachedShow;
property atcDeletedColor: TColor read FDeletedColor write FDeletedColor;
property atcInsertedColor: TColor read FInsertedColor write FInsertedColor;
property atcModifiedColor: TColor read FModifiedColor write FModifiedColor;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('ATC DB Compo', [TatcDBGrid]);
end;

constructor TatcDBGrid.Create(AOwner: TComponent);
{*
Description: Record Type Showing is All except Deletes.
*}

begin
inherited;
FCachedShow := csNormal;
FDeletedColor := clGray;
FInsertedColor := clAqua;
FModifiedColor := clRed;
end;

procedure TatcDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer;
Column: TColumn; State: TGridDrawState);
{*
Description: On Drawing Column Color Updated Records.
*}
var
ARect: TRect;
begin
inherited;
if not Assigned(Column.Field) then
exit;
// Copy Rect into Variable.
CopyRect(ARect, Rect);
begin
// if current record is modified
begin
Canvas.Brush.Color := atcModifiedColor;
Canvas.Font.Color := clBlack;
Canvas.FillRect(Rect);
DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text),
ARect,
AlignFlags[Column.Alignment] or
RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
end
// if current record is inserted.
begin
Canvas.Brush.Color := atcInsertedColor;
Canvas.Font.Color := clBlack;
Canvas.FillRect(Rect);
DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text),
ARect,
AlignFlags[Column.Alignment] or
RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
end
// if current record is deleted.
begin
Canvas.Brush.Color := atcDeletedColor;
Canvas.Font.Color := clWhite;
Canvas.FillRect(Rect);
DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text),
ARect,
AlignFlags[Column.Alignment] or
RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
end;
end;
end;

procedure TatcDBGrid.DrawDataCell(const Rect: TRect; Field: TField;
State: TGridDrawState);
{*
Description: Draw Cell
*}
var
ARect: TRect;
begin
inherited;
CopyRect(ARect, Rect);

begin
// if current record is modified.
begin
Canvas.Brush.Color := clRed;
Canvas.Font.Color := clBlack;
Canvas.FillRect(Rect);
DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field,
Field.Alignment)]);
end
// if current record is inserted.
begin
Canvas.Brush.Color := clAqua;
Canvas.Font.Color := clBlack;
Canvas.FillRect(Rect);
DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field,
Field.Alignment)]);
end
// if current record is deleted.
begin
Canvas.Brush.Color := clGray;
Canvas.Font.Color := clWhite;
Canvas.FillRect(Rect);
DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field,
Field.Alignment)]);
end;
end;
end;

procedure TatcDBGrid.SetCachedShow(const Value: TCachedShow);
{*
Description: Record type for showing in grid.
Parameters: Value cached record show.
*}

begin
FCachedShow := Value;
if ComponentState = [csDesigning] then
exit;
if not Assigned(DataSource) or not Assigned(DataSource.DataSet) then
exit;
// for showing selected record type only.
begin
case FCachedShow of
csAll:
TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted,
rtDeleted, rtUnmodified];
csModify:
TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified];
csUnModify:
TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtUnmodified];
csInserted:
TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtInserted];
csRemoved:
TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtDeleted];
csNormal:
TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted,
rtUnmodified];
end;
end;
end;

end.

## 2009. október 23., péntek

### Copy a Paradox table with all its family members from one place to another on my system

Problem/Question/Abstract:

How can I copy a Paradox table with all its family members from one place to another on my system?

Introduction

When I discovered the TBatchMove component, it was a real god-send because I now had a means to copy and append data from one Paradox table to another, which was my desktop database of choice. But the one thing that irked me about it was that if I wanted to perform a physical copy of a table with all its indexes and other family members, TBatchMove wouldn't copy them. It would only copy the table itself.

An obvious workaround to this dilemma would be to do an operating system level copy of all files in the directory that have the same name as the table. But the problem with this is that a system-level copy is indescriminant of the file types that are being copied. What does this mean? Well, one thing is that if a subdirectory residing in the source directory happens to have the same name as the table, its entire contents will be copied to the destination. Also, the potential for copying other stray files with the same name but having no association with the table exists. So what happens is that you have to write a lot of logic just to deal with those two situations.

So, what do you do when there doesn't seem to be anything available in the VCL that will let you copy a table and all its associates at once. Even the TTable's BatchMove method won't do it. Well, when all else fails, go to the BDE itself.

When I was programming in Paradox and Paradox for Windows, I took it for granted that I could issue a Paradox copy command and all my tables and their family members would be copied all together. All that changed in Delphi, but that doesn't mean it's not available. It's just a matter of doing some programming. And surprisingly enough, it's not that hard to do.

Copying the File

Doing BDE stuff is rarely a one step operation. Usually, you have to instantiate or initialize a few things before you actually make the call you want to make. The BDE call that we want to perform the copy, DBICopyTable, is no exception. But thankfully, it only requires a single prerequisite object to be created before making the call. That object is simply a TDatabase object. DBICopyTable uses the TDatabase object's Handle property internally to get information about the file being copied. Specifically, once it has the handle to the object, it uses the Locale property information get the language driver information it needs so it knows what files to copy. Once we create the database object, we're ready to make the call. Let's look at it in detail.

DBICopyTable takes four (5) parameters. They're explained below:

Parameter Name
Type
Description
hDB
hDBIDb
In English, this is read Database Handle, the Handle property of a TDatabase object.
bOverwrite
Boolean
True = Overwrite the destination file if it exists
False = Don't overwrite. If the file exists, an exception will occur. This is trapped by the Check function which will also pop up a message describing the error.
pszSrcTableName
PChar
The fully qualified (path and file name) name of the source table to copy
pszSrcDriverType
PChar
The driver type of the source table. If you supply the file extension, you can set this to nil. Otherwise, you have to specify a valid driver type (i.e. 'STANDARD', SQLServer, etc.).
pszDestName
PChar
The fully qualified name of the destination table.

Here's some code that encapsulates the call (we'll discuss it below):

{========================================================================
This will copy a Paradox or dBase table from one directory to another.
Note that this does not use BDE aliases. It would be possible to do that
by declaring parameters for the source and destination databases,
respectively.}
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
= = = = = = = = = = = = = = = = = = = = = = = = = = = =
procedure CopyPdoxTable(SrcTbl, DstTbl: string; Overwrite: Boolean);
var
DB: TDatabase;
STbl, DTbl: string;
begin
{Since we're using path names and not BDE aliases, we have to do
some checking of the paths to see if they're blank; that is, the
user passed just the file name to the procedure, and not the
FULLY QUALIFIED file name. In that case, we merely set the source
and destination to the application's EXEName directory}
if (ExtractFilePath(SrcTbl) = '') then
STbl := ExtractFilePath(Application.EXEName) + SrcTbl
else
STbl := SrcTbl;

if (ExtractFilePath(DstTbl) = '') then
DTbl := ExtractFilePath(Application.EXEName) + DstTbl
else
DTbl := DstTbl;

{First, check to see if the source file actually exists. If it does
create a TDatabase that points to the source file's directory.
This can actually point anywhere using the method we're using because
we're specifying fully qualified file names as entries as opposed to.
The important thing though, is to set it to a valid directory}
if FileExists(STbl) then
begin
DB := TDatabase.Create(nil);
with DB do
begin
Connected := False;
DatabaseName := ExtractFilePath(SrcTbl);
DriverName := 'STANDARD';
Connected := True;
end;

{Do the table copy from source to dest. Notice the PChar typecast of STbl
and DTbl. The BDE function actually calls for a DBITBLNAME type. But this
is just a null-terminated string - a PChar - so we can save ourselves a
lot of time by just typecasting the strings.}
Check(DBICopyTable(DB.Handle, Overwrite, PChar(STbl), nil, PChar(DTbl)));

//Get rid of the database component.
DB.Free;
end;
else
ShowMessage('Could not copy the table. It is not in the location specified.');

end;

Note that the boldface type is the code you actually write. I did it this way because I added a lot of comments and they got in the way of the code.

So, what's going on in the code?

Well, the first thing that happens is a little sanity check. If only the file name of the table is passed to the procedure, it assumes that the file resides in the same directory as the application. Then the copying operation is enclosed in a conditional statement and only executes depending upon the existence of the file itself.

Once that's done, we create a TDatabase object in memory, set its DatabaseName property to the directory location of the file by calling ExtractFilePath, specify the STANDARD driver (Paradox and dBase files) as our table language driver, then connect. Pretty simple.

Then, it's a simple matter of calling DbiCopyTable, inputting the parameters described above. Notice that I enclose the call in the Check function. This is a special BDE call which checks the error constant returned from a BDE call. While the BDE is fairly complex, it's error tracking is fairly robust. In the old days of the BDE, you had to trap all the constants yourself, then display error messages depending upon the value returned. Check handles all that for you.

Well, that's it. Try it out and see how it works for you.

## 2009. október 22., csütörtök

### How to colorize an image

Problem/Question/Abstract:

How to colorize an image

Assumes 8 bit R, G, Bs packed into RGB. Luma is 0 - 255

function Colorize(RGB, Luma: Cardinal);
var
l, r, g, b: Single;
begin
Result := Luma;
if Luma = 0 then { it's all black anyway}
Exit;
l := Luma / 255;
r := RGB and \$FF * l;
g := RGB shr 8 and \$FF * l;
b := RGB shr 16 and \$FF * l;
Result := Round(b) shl 16 or Round(g) shl 8 or Round(r);
end;

## 2009. október 21., szerda

### System menu in tray-icon mode

Problem/Question/Abstract:

I always wanted to show the Main window's system menu also when the only thing the user could click on the screen of my application, was the tray icon. Like Total Commander is doing...

With the most components provinding very-easy-to-use icon tray support, you can specify to show up a popupmenu, or you can catch the click event.

But you can't easily show the same menu as if you right-clicked on application's taskbar icon.

Just catch the WM_CLICK event over the icon, or simply use the OnClick event as shown:

procedure TfrmMain.tiIconClick(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
begin
TrackPopupMenuEx(I, TPM_HORIZONTAL, X, Y, Handle, nil);
end;

Be warned: you must specify X and Y as screen coordinates, not relative to the icon, like some components do.

## 2009. október 20., kedd

### A Simple Property Editor

Problem/Question/Abstract:

How can I create a simple property editor?

This is an introductory level article about creating a simple property editor that I hope will get you started. I'll provide enough information about the DSGNINTF.PAS (Design interface that holds the TPropertyEditor class) file so you can finish the article with a sense of that you are able to create a property editor.

TPropertyEditor

The following is a cut and paste of the TPropertyEditor class declaration found in DSGNINTF.PAS:

TPropertyEditor = class
private
FDesigner: TFormDesigner;
FPropList: PInstPropList;
FPropCount: Integer;
function GetPrivateDirectory: string;
procedure SetPropEntry(Index: Integer; AInstance: TComponent;
APropInfo: PPropInfo);
protected
function GetPropInfo: PPropInfo;
function GetFloatValue: Extended;
function GetFloatValueAt(Index: Integer): Extended;
function GetMethodValue: TMethod;
function GetMethodValueAt(Index: Integer): TMethod;
function GetOrdValue: Longint;
function GetOrdValueAt(Index: Integer): Longint;
function GetStrValue: string;
function GetStrValueAt(Index: Integer): string;
function GetVarValue: Variant;
function GetVarValueAt(Index: Integer): Variant;
procedure Modified;
procedure SetFloatValue(Value: Extended);
procedure SetMethodValue(const Value: TMethod);
procedure SetOrdValue(Value: Longint);
procedure SetStrValue(const Value: string);
procedure SetVarValue(const Value: Variant);
public
destructor Destroy; override;
procedure Activate; virtual;
function AllEqual: Boolean; virtual;
procedure Edit; virtual;
function GetAttributes: TPropertyAttributes; virtual;
function GetComponent(Index: Integer): TComponent;
function GetEditLimit: Integer; virtual;
function GetName: string; virtual;
procedure GetProperties(Proc: TGetPropEditProc); virtual;
function GetPropType: PTypeInfo;
function GetValue: string; virtual;
procedure GetValues(Proc: TGetStrProc); virtual;
procedure Initialize; virtual;
procedure Revert;
procedure SetValue(const Value: string); virtual;
function ValueAvailable: Boolean;
property Value: string read GetValue write SetValue;
end;

Whew! that's a lot of stuff, isn't it? Add to the fact that the Tools API is poorly documented, and you've got a lot confusion to deal with. There's a little relief in the Delphi 2.0 help file, but the way it's organized can leave you with the sinking feeling that you're in way over your head. After you've done a few property editors, it's really not that hard.

The Trick to Writing Property Editors

One of the biggest problems with technical documentation is that it's technical. Not much conceptual material is ever covered in tech specs or tech manuals. This leaves it up to the programmer to extrapolate the underlying concepts. I'm of the opinion that if something has the possibility of being a widely used feature, you should cover not only the technical specifications, but the conceptual points as well. Gaining conceptual understanding is the real trick to creating property.

The trick to writing property editors is understanding the virtual methods and what they do. Writing your own custom property editors is all about overriding the proper methods of the TPropertyEditor class to get the functionality out of property editor that you require. Granted, there are a lot of very complex property editors out there. But whether simple or complex, they're all built in a similar fashion: they override default functionality of TPropertyEditor.

Once you let this concept sink in, and as you gain more experience in building components, writing a property editor merely becomes the task of overriding the appropriate methods to get your job done.

Furthermore, the DSGNINFT.PAS is thoroughly commented. When constructing components that will have property editors, make sure that this file is open in the editor so you can refer to the documentation covering the virtual methods you will be overriding. As an aside, if you do BDE programming, having the BDE.INT (Delphi 2.0) or DBIPROCS.INT, DBITYPES.INT, DBIERRS.INT (Delphi 1.0) is essential to successful BDE programming

The Value List: the Simplest Type of Property Editor

Properties that display value lists are common to components. In fact, you see them all the time. For instance, a value list property that everyone has used is the Align property.

Value lists are simple enumerated types, which are merely a collection of sequentially ordered elements in a list. The first item has an ordinal value of 0, the second 1, and so forth. Enumerated types are useful in communicating with the user using a set of named choices rather than ordinal or numeric choices. For instance, the Align element alBottom is much easier to understand than '0,' which is its ordinal value in the list. In this case, the ordinal value has no clear conceptual context.

To create a property editor that presents a value list to a user in the object inspector is very simple and requires only a few steps. Here is a brief synopsis of what you have to do before we go into detail:

First, define and declare your enumerated type under a new type section.
Under the enumerated type declaration, declare your class, including the functions you will be overriding in your code.
Write your code in the implementation section of the unit.

Sounds pretty simple, right? It is. So let's go and create one now, then we'll discuss it in detail below.

...other code

interface

type
TEnumMonth = (emJan, emFeb, emMar,
emApr, emMay, emJun,
emJul, emAug, emSep,
emOct, emNov, emDec);

TEnumMonths = class(TEnumProperty)
public
function GetAttributes: TPropertyAttributes; override;
function AllEqual: Boolean; override;
end;

implementation

...other code

function TEnumMonths.AllEqual: Boolean;
begin
Result := True;
end;

function TEnumMonths.GetAttributes: TPropertyAttributes;
begin
Result := [paMultiSelect, paValueList];
end;

procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TEnumMonth), TPSIBaseExt, 'RangeBegin',
TEnumMonths);
RegisterPropertyEditor(TypeInfo(TEnumMonth), TPSIBaseExt, 'RangeEnd', TEnumMonths);
end;

The property editor listed above was created to serve a singular purpose: Allow the user to select a specific month from a list of months, rather than typing in a month value code himself (which is more work than the user needs and is also prone to spelling errors).

This component modernizes a cumbersome style of interaction in existing applications. In these applications users were required to enter month ranges as a six-digit string beginning with current two-digit year plus the four digit month/day combination (eg., YYMMDD). Past experience said that runtime errors or empty result sets from queries that used the range values were usually the result of mistyping. So the property editor was created to let the user pick a month for both the starting month and ending month of the range of values they wanted to extract. This explains why in the code above I registered the property editor for both the RangeBegin and RangeEnd properties.

Elsewhere in the component, I have created an array type of type String and created two arrays representing the starting month and ending month code values, respectively.

Here's the array type declaration:

type
TMonthRng = array[0..11] of string;
....

Here are the declarations and initializations of the arrays themselves:

var
stmonArr,
enmonArr: TMonthRng;
begin
stmonArr[0] := '0101';
stmonArr[1] := '0201';
stmonArr[2] := '0301';
stmonArr[3] := '0401';
stmonArr[4] := '0501';
stmonArr[5] := '0601';
stmonArr[6] := '0701';
stmonArr[7] := '0801';
stmonArr[8] := '0901';
stmonArr[9] := '1001';
stmonArr[10] := '1101';
stmonArr[11] := '1201';
enmonArr[0] := '0131';
enmonArr[1] := '0229';
enmonArr[2] := '0331';
enmonArr[3] := '0430';
enmonArr[4] := '0531';
enmonArr[5] := '0630';
enmonArr[6] := '0731';
enmonArr[7] := '0831';
enmonArr[8] := '0930';
enmonArr[9] := '1031';
enmonArr[10] := '1130';
enmonArr[11] := '1231';

...

By doing things in this manner, one can easily get the appropriate value needed by passing the ordinal value of the appropriate enumerated type as an index of an element in the array. For example, let's say the user chose emApr as his/her starting month. The ordinal value of emApr is 3. Referencing that value in the stmonArr array would produce the string '0401.' What I've essentially done here is eliminate the need for the user to do anything more than choose an appropriate month to start with. The proper code is handled by the program. Here's some sample code that demonstrates how it's done:

procedure ReturnMonthCode(Index: Integer; StartMonth: Boolean): string;
var
stmonArr,
enmonArr: TMonthRng;
begin
stmonArr[0] := '0101';
stmonArr[1] := '0201';
stmonArr[2] := '0301';
stmonArr[3] := '0401';
stmonArr[4] := '0501';
stmonArr[5] := '0601';
stmonArr[6] := '0701';
stmonArr[7] := '0801';
stmonArr[8] := '0901';
stmonArr[9] := '1001';
stmonArr[10] := '1101';
stmonArr[11] := '1201';

enmonArr[0] := '0131';
enmonArr[1] := '0229';
enmonArr[2] := '0331';
enmonArr[3] := '0430';
enmonArr[4] := '0531';
enmonArr[5] := '0630';
enmonArr[6] := '0731';
enmonArr[7] := '0831';
enmonArr[8] := '0930';
enmonArr[9] := '1031';
enmonArr[10] := '1130';
enmonArr[11] := '1231';

if StartMonth then
Result := stMonArr[Index]
else
Result := enMonArr[Index];
end;

To actually use ReturnMonthCode all we do is the following:

var
S: string;
begin

S := ReturnMonthCode(Ord(RangeBegin), True);

Remember, RangeBegin is a property of type TEnumArray. Therefore, to access its ordinal value, all we need do is apply the Ord function to it.

Based on the information above, you should be able to create at the very least a simple property editor like the example above. For more complex property editors, you will have to override more of the methods; but remember, don't be daunted by the code. The trick is overriding the default methods with your own.

## 2009. október 19., hétfő

### How to detect if DCOM is installed

Problem/Question/Abstract:

How to detect if DCOM is installed

function IsDCOMInstalled: Boolean;
var
OLE32: HModule;
begin
Result := not (IsWin95 or IsWin95OSR2);
if not Result then
begin
if OLE32 > 0 then
try
Result := GetProcAddress(OLE32, PChar('CoCreateInstanceEx')) <> nil;
finally
FreeLibrary(OLE32);
end;
end;
end;

## 2009. október 18., vasárnap

Problem/Question/Abstract:

I want to open a wave file in my application, but how do I know that it is really a wave file and not just a file with *.wav extension?

First you have to know what the structure of a wave file is. I'd create a record which represent this structure:

type
ident1: array[0..3] of Char;      // Must be "RIFF"
len: DWORD;                       // Remaining length after this header
ident2: array[0..3] of Char;      // Must be "WAVE"
ident3: array[0..3] of Char;      // Must be "fmt "
reserv: DWORD;                    // Reserved 4 bytes
wFormatTag: Word;                 // format type
nChannels: Word;                  // number of channels (i.e. mono, stereo, etc.)
nSamplesPerSec: DWORD;            //sample rate
nAvgBytesPerSec: DWORD;           //for buffer estimation
nBlockAlign: Word;                //block size of data
wBitsPerSample: Word;             //number of bits per sample of mono data
cbSize: Word;                     //the count in bytes of the size of
ident4: array[0..3] of Char;      //Must be "data"
end;

With this structure you can get all the information's about a wave file you want to.
After this header following the wave data which contains the data for playing the wave file.

Now we trying to get the information's from a wave file. To be sure it's really a wave file, we test the information's:

const
riff = 'RIFF';
wave = 'WAVE';
var
f: TFileStream;
begin
if not FileExists(Filename) then
exit; //exit the function if the file does not exists

try

if w.ident1 <> riff then
begin //Test if it is a RIFF file, otherwise exit
Showmessage('This is not a RIFF File');
exit;
end;

if w.ident2 <> wave then
begin //Test if it is a wave file, otherwise exit
Showmessage('This is not a valid wave file');
exit;
end;

finally
f.free;
end;

Result := w;
end;

## 2009. október 17., szombat

### Delete the row in TStringGrid component

Problem/Question/Abstract:

How can I delete the row in TStringGrid component?

If you worked with TStringGrid component, then you saw that in this component the Borland developers not provided the method for row deleting.
In this tip I describe the few ways for it:

1. navigate by rows and copy the row contains to the prev row:

procedure DeleteRow(yourStringGrid: TStringGrid; ARow: Integer);
var
i, j: Integer;
begin
with yourStringGrid do
begin
for i := ARow to RowCount - 2 do
for j := 0 to ColCount - 1 do
Cells[j, i] := Cells[j, i + 1];
RowCount := RowCount - 1
end;
end;

2. the modificated #1:

procedure DeleteRow(yourStringGrid: TStringGrid; ARow: Integer);
var
i: Integer;
begin
with yourStringGrid do
begin
for i := ARow to RowCount - 2 do
Rows[i].Assign(Rows[i + 1]);
RowCount := RowCount - 1
end;
end;

3. the "hacked" way. The TCustomGrid type (the TStringGrid is TCustomGrid's successor) have the DeleteRow method. But this method allocated not in public section but in protected section. So the all successors can "see" this DeleteRow method.

type
THackStringGrid = class(TStringGrid);

procedure DeleteRow(yourStringGrid: TStringGrid; ARow: Integer);
begin
with THackStringGrid(yourStringGrid) do
DeleteRow(ARow);
end;

Personally I use the third method but the first and second are more visual.

Also you should clear the Row after moving the data to the row above.  If not you will get the old date back when you add a Row.

if StringGrid.RowCount > 2 then
begin
if StringGrid.Selection.Top <> (StringGrid.RowCount - 1) then
begin
for iRow := StringGrid.Selection.Top to (StringGrid.RowCount - 2) do
begin
for iCol := 0 to (StringGrid.ColCount - 1) do
begin
StringGrid.Cells[iCol, iRow] := StringGrid.Cells[iCol, iRow + 1];
end;
end;
end;
StringGrid.Rows[StringGrid.RowCount - 1].Clear;
StringGrid.RowCount := StringGrid.RowCount - 1;

## 2009. október 16., péntek

### Extract string property values from DFM files

Problem/Question/Abstract:

Does anybody know the name of the routine used in the IDE that enables control characters embedded into a string to be recognised. For example the characters 'Line 1'#13#10'Line 2' are recognised by the compiler as a single string literal. I'd like to build a similar facility into an application. Is a single routine used for this or is it embedded somewhere in the parser of the compiler?

I'm pretty sure that the compiler uses an internal routine for this which is not accessible to us mere mortals. Perhaps you can extract something useful from the unit below. I wrote it to extract string property values from DFM files. It is a work in progress, so if you want to use it for the same purpose be aware that you may have DFMs it will not be able to digest without modifications.

unit DFMParser;

interface

uses
classes, sysutils;

type
TBaseParser = class
private
FText: string;
FCurrent, FAnchor: Integer;
FToken: string;
protected
procedure Error(const fmt: string; const A: array of const); overload;
procedure DropAnchor;
procedure NextToken;
procedure NextChar;
procedure SkipWhitespace;
procedure SkipToEol;
procedure SkipTo(ch: Char);
procedure SkipToString(const S: string);
function EndOfText: Boolean;
function IsTokenChar: Boolean;
function IsWhiteSpace: Boolean;
function CurrentChar: Char;
function LastWord: string;
function ParseEncodedChar: Char;
function ParseQuotedString: string;
function ParseStringValue: string;
public
procedure Parse; virtual; abstract;
constructor Create(const S: string); virtual;
end;

TParsePropertyEvent = procedure(const aComponentName, aPropertyName,
aPropertyValue: string) of object;

TDFMParser = class(TBaseParser)
private
FParsePropertyEvent: TParsePropertyEvent;
protected
procedure ParseComponent;
procedure ParseProperty(const componentName: string);
procedure ParsePropertyString(const componentName, propertyName: string);
function TokenIsObject: Boolean;
function IsEndToken: Boolean;
procedure DoPropertyEvent(const componentName, propertyname, propvalue: string);
public
procedure Parse; override;
write FParsePropertyEvent;
end;

EDFMParserError = class(Exception);

TTranslationItemEvent = procedure(const name, value: string) of object;

TTranslationParser = class(TBaseParser)
private
FTranslationItemEvent: TTranslationItemEvent;
procedure ParseStringConstant;
procedure DoTranslationItem(const name, value: string);
public
constructor Create(const S: string); override;
procedure Parse; override;
write FTranslationItemEvent;
end;

implementation

uses
charsets;

const
quote = '''';

constructor TBaseParser.Create(const S: string);
begin
FText := S;
FCurrent := 1;
end;

function TBaseParser.CurrentChar: Char;
begin
result := FText[FCurrent];
end;

procedure TBaseParser.DropAnchor;
begin
FAnchor := FCurrent;
end;

function TBaseParser.EndOfText: Boolean;
begin
result := FCurrent > Length(FText);
end;

procedure TBaseParser.Error(const S: string);
begin
raise EPArserError.Create(S);
end;

procedure TBaseParser.Error(const fmt: string; const A: array of const);
begin
Error(Format(fmt, A));
end;

function TBaseParser.IsTokenChar: Boolean;
begin
result := (Currentchar in Charsets.IdentifierChars) or (CurrentChar = '.');
end;

function TBaseParser.IsWhiteSpace: Boolean;
begin
result := Currentchar in [#1..#32];
end;

function TBaseParser.LastWord: string;
begin
Assert(FAnchor <= FCurrent);
result := Copy(FText, FAnchor, FCurrent - FAnchor);
end;

procedure TBaseParser.NextChar;
begin
Inc(FCurrent);
if EndOfText then
Error('Unexpected end of text');
end;

procedure TBaseParser.NextToken;
begin
SkipWhitespace;
DropAnchor;
while not EndOfText and IsTokenChar do
Inc(FCurrent);
FToken := LastWord;
end;

procedure TBaseParser.SkipTo(ch: Char);
begin
while not EndOfText and (Currentchar <> ch) do
NextChar;
Inc(FCurrent);
end;

procedure TBaseParser.SkipToString(const S: string);
var
P: PChar;
begin
p := StrPos(@FText[FCurrent], Pchar(S));
if Assigned(p) then
FCurrent := p - PChar(FText) + 1 + Length(S)
else
end;

procedure TBaseParser.SkipToEol;
begin
while not EndOfText and (FText[FCurrent] <> #10) do
Inc(FCurrent);
end;

procedure TBaseParser.SkipWhitespace;
begin
while not EndOfText and IsWhiteSpace do
Inc(FCurrent);
end;

function TBaseParser.ParseQuotedString: string;
begin
Assert(CurrentChar = quote);
Result := '';
repeat
DropAnchor;
while CurrentChar <> quote do
NextChar;
Result := Result + LastWord;
NextChar;
if CurrentChar = quote then
Result := Result + quote; {literal quote}
until
CurrentChar <> quote;
SkipWhitespace;
end;

function TBaseParser.ParseEncodedChar: Char;
var
allowed: Charsets.TCharset;
n: Integer;
begin
Assert(CurrentChar = '#');
NextChar;
DropAnchor;
if CurrentChar = '\$' then
begin
allowed := CHarsets.HexNumerals;
NextChar;
end
else
allowed := Charsets.IntegerChars;
while CurrentChar in allowed do
NextChar;
n := StrToInt(LastWord);
if n > High(Byte) then
Error('Encountered UNICODE character in string, cannot handle that.');
Result := Char(n);
end;

function TBaseParser.ParseStringValue: string;
begin
Result := '';
while True do
case CurrentChar of
quote:
Result := Result + ParseQuotedString;
'#':
Result := Result + ParseEncodedChar;
'+':
begin
NextChar;
SkipWhitespace;
end;
else
Break;
end;
end;

{ TDFMParser }

procedure TDFMParser.DoPropertyEvent(const componentName, propertyname, propvalue:
string);
begin
if Assigned(FParsePropertyEvent) then
FParsePropertyEvent(componentName, propertyname, propvalue);
end;

function TDFMParser.IsEndToken: Boolean;
begin
result := Token = 'end';
end;

procedure TDFMParser.Parse;
begin
while not EndOfText do
begin
ParseComponent;
SkipWhitespace;
end;
end;

procedure TDFMParser.ParseComponent;
var
componentName: string;
begin
if FToken = '' then
NextToken;
if not TokenIsObject then
Error('Expected: inherited or object, found : %s', [Token]);
NextToken;
componentName := Token;
SkipToEol;
repeat
NextToken;
if TokenIsObject then
ParseComponent
else if not IsEndToken then
ParseProperty(componentName);
until
IsEndToken or EndOfText;
if IsEndToken then
FToken := '';
end;

procedure TDFMParser.ParseProperty(const componentName: string);
var
propname: string;
begin
propname := Token;
SkipWhitespace;
if CurrentChar <> '=' then
Error('Expected: =, found %s', [Currentchar]);
NextChar;
SkipWhitespace;
case CurrentChar of
'{':
SkipTo('}');
'(':
SkipTo(')');
'[':
SkipTo(']');
quote, '#':
ParsePropertyString(componentName, propname);
else
SkipToEol
end;
end;

procedure TDFMParser.ParsePropertyString(const componentName, propertyName: string);
var
propvalue: string;
begin
propvalue := ParseStringValue;
if propvalue <> '' then
DoPropertyEvent(componentName, propertyname, propvalue);
end;

function TDFMParser.TokenIsObject: Boolean;
begin
Result := (Token = 'inherited') or (Token = 'object')
end;

{ TTranslationParser }

constructor TTranslationParser.Create(const S: string);
const
resStr = 'resourcestring';
var
lS: string;
resourceStringPos: Integer;
n1, n2: Integer;
begin
{Isolate the resourcestring section. We expect only one}
lS := LowerCase(S);
resourceStringPos := Pos(resStr, lS);
if resourceStringPos = 0 then
inherited Create('')
else
begin
{look for an \$ifdef german}
n1 := Pos('{\$ifdef german', lS);
if n1 > 0 then
begin
{look for the following \$else}
Delete(lS, 1, n1 - 1);
n2 := Pos('{\$else}', lS);
if n2 = 0 then
Delete(lS, 1, n2 - 1);
Inc(n1, n2 - 1);
{look for the \$ENDIF}
n2 := Pos('{\$endif}', lS);
if n2 = 0 then
inherited Create(Copy(S, n1, n2 - 1));
end
else
begin
{look for an \$ifndef german}
n1 := Pos('{\$ifndef german', lS);
if n1 = 0 then
inherited Create('')
else
begin
{in the \$ifndef german construct the resourcestring keyword often comes after the \$ifndef.}
if n1 < resourceStringPos then
n1 := resourceStringPos + Length(resstr);
Delete(lS, 1, n1 - 1);
{look for the \$ENDIF}
n2 := Pos('{\$endif}', lS);
if n2 = 0 then
inherited Create(Copy(S, n1, n2 - 1));
end;
end;
end;
end;

procedure TTranslationParser.DoTranslationItem(const name, value: string);
begin
if Assigned(FTranslationItemEvent) then
FTranslationItemEvent(name, value);
end;

procedure TTranslationParser.Parse;
begin
while not EndOfText do
begin
ParseStringConstant;
SkipWhitespace;
end;
end;

procedure TTranslationParser.ParseStringConstant;
var
name, value: string;
begin
if EndOfText then
Exit;
NextToken;
name := Token;
if EndOfText then
Exit;
if CurrentChar <> '=' then
Error('Expected: =, found "%s"', [CurrentChar]);
NextChar;
if EndOfText then
Exit;
value := ParseStringValue;
SkipWhiteSpace;
if not EndOfText and (CurrentChar = ';') then
NextChar;
DoTranslationItem(name, value);
end;

begin
while True do
begin
SkipWhitespace;
if not EndOfText then
begin
case CurrentChar of
'/':
SkipToEol; { single line comment }
'{':
SkipTo('}'); { comment }
'(':
begin
NextChar;
if CurrentChar = '*' then
SkipToString('*)')
else
Error('Expected: comment or indentifier, found: "(%s"', [CurrentChar]);
end;
else
Break
end;
end
else
Break;
end;
end;

end.

unit Charsets;

interface

type
TCharSet = set of AnsiChar;
const
Signs: TCharset = ['-', '+'];
Numerals: TCharset = ['0'..'9'];
HexNumerals: TCharset = ['A'..'F', 'a'..'f', '0'..'9'];
IntegerChars: TCharset = ['0'..'9', '-', '+'];
IdentifierChars: TCharset = ['a'..'z', 'A'..'Z', '0'..'9', '_'];
var
Digits, Letters, LowerCaseLetters, UpperCaseLetters: TCharSet;
FloatChars, SciFloatChars: TCharset;
AlphaNum, NonAlphaNum: TCharset;

{ Need to call this again when locale changes.  }
procedure SetupCharsets;

implementation

uses
Windows, Sysutils;

var
locale: DWORD = 0;

procedure SetupCharsets;
var
ch: AnsiChar;
begin
Exit
else
LowerCaseLetters := [];
UpperCaseLetters := [];
AlphaNum := [];
NonAlphaNum := [];
Digits := Numerals;
for ch := Low(ch) to High(ch) do
begin
if IsCharAlpha(ch) then
if IsCharUpper(ch) then
Include(UpperCaseLetters, ch)
else
Include(LowerCaseLetters, ch);
if IsCharAlphanumeric(ch) then
Include(AlphaNum, ch)
else
Include(NonAlphaNum, ch);
end;
Letters := LowerCaseLetters + UpperCaseLetters;
FloatChars := IntegerChars;
Include(FloatChars, DecimalSeparator);
SciFloatChars := FloatChars + ['e', 'E'];
end;

initialization
SetupCharsets;
end.

## 2009. október 15., csütörtök

### A Simple example of Artificial Intelligence using Delphi Array

Problem/Question/Abstract:

A Simple example of Artificial Intelligence using Delphi Array (Computer simulates learning process of human, learning by correcting mistakes !)

Artificial Intelligence (AI) is an advance branch of science that studies the process of human thinking and attempts to apply the knowledge to simulate the same process in machines.  As computers are far ahead in the marathon of processing machines, AI is considered to be the branch of Computer Science than that of General Science.
There have been many research and development in the field of Artificial Intelligence. The area of research include speech and pattern recognition, natural language processing, learning from previous experiences (learning by making and correcting mistakes!), reasoning under the situations providing limited or incomplete information etc. AI is practically applied in the field of computer games, expert systems, neural networks, robotics and many other fields of science and technology.

In this article we will try to demonstrate a very simple practical example of artificial Intelligence programming in Delphi using Delphi arrays. I have chosen a Nepali game named "GATTA TIPNE KHEL" (meaning pebble picking game) for this purpose. We can see small children playing this game in the playground.

(By the way, Nepal, my nation, is a small Asian country between India and China. Recently Nepal was in the main highlight of media for the notorious Royal Massacre in which the whole family of the ruling king were cruelly killed.)

In this pebble picking game a pile of some pebbles is kept in the ground. One of the two players picks one, two or three pebbles at a time in his turn, leaving the pile for the other player to pick for his alternate turn. In this alternate picking process, the player who picks the last pebble(s) will be the loser and called to be a DOOM in Nepali.
The main logic of the game is to leave the pile of pebbles with 13, 9, 5 or 1 pebble(s) for the opponent to pick.
In the program the starting number of pebbles are set to 17, 21, 25, 29 &#8230; etc. so that computer could win always if it does not make a mistake. But in the real play computer seems to be gradually learning by correcting mistakes of the previously played games. At last it finds all its mistakes and corrects them to become an unbeatable champion. It seems computer simulates the psychological learning process of animal, learning by correcting and not repeating the mistakes.
A multidimensional array of elements (1..4,1..3) is chosen as the instruction book for the computer to pick the pebbles. The instruction book contains four pages with three lines of instructions to pick pebbles. The first line instructs to pick a single pebble, the second line instructs to pick 2 and the third line instructs to pick 3 pebbles. At the beginning, computer chooses a random page and a random line of instruction to pick the pebble. When the game finishes, if computer looses the game, the last instruction is red-marked (erased) and the instruction will not be read in the future. After playing many games, all the instructions leading to a lost game will be red marked and there will be left only the instructions those lead to a win.

Well, it is enough for the description of the game.
Let us jump directly to the code below:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Panel1: TPanel;
LabelPeb1: TLabel;
LabelPeb2: TLabel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
Label1: TLabel;
ComboBox1: TComboBox;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
LabelIWon: TLabel;
LabelYouWon: TLabel;
LabelTotPlayed: TLabel;
ListBox1: TListBox;
GroupBox1: TGroupBox;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
BitBtn5: TBitBtn;
Panel5: TPanel;
Labelbtn: TLabel;
BitBtnResign: TBitBtn;
Label7: TLabel;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure BitBtnResignClick(Sender: TObject);
procedure LabelbtnClick(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }

//Procedure to display remaining Pebbles
procedure DispPebbles(const nPebs: integer);
//Procedure to reset Variables and Labels after a game is finished
procedure Finish;
//Procedure to enable or Disable some controls;
procedure ManageEnabling(lValue: Boolean);
//Procedure to display winning or loosing messages
procedure Messaging(const lost: Boolean; const resigning: Boolean);
//Real Procedure for playing the game
procedure LearnByMistakes;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

var
PlayedGames, ComputerWon: Integer;
totPebs, RemainPebs, nTurn: Integer;
OldPageNum, OldLineNum: Integer;

//18 possible permutations of 3 digits: 1,2 and 3
//to determine the number of pebbles to take for the computer
aPermutations: array[1..6, 1..3] of integer;
// A book containing the instruction pages(4) and lines(3 in each page) to draw the pebbles for the computer
aPages: array[1..4, 1..3] of integer;

procedure TForm1.FormCreate(Sender: TObject);
// Permutations of 1,2 and 3  in the group of 3s to fill the permutation Array
const
cPermutations = '123132213231312321';
var
x, y: Integer;
begin
//Filling  Permutation Array
for x := 1 to 6 do
for y := 1 to 3 do
aPermutations[x, y] := strtoInt(copy(cPermutations, (x - 1) * 3 + y, 1));
//Filling the lines of all pages of the instruction Book (array aPages[1..4,1..3]).
for x := 1 to 4 do
for y := 1 to 3 do
aPages[x, y] := y;
ComboBox1.ItemIndex := 1;
PlayedGames := 0;
ComputerWon := 0;
totPebs := 17; {Default to 17 pebbles}
RemainPebs := 17; {All are intact up to Now}
end;

procedure TForm1.DispPebbles(const nPebs: integer);
begin
LabelPeb1.Caption := intToStr(nPebs);
LabelPeb2.Caption := LabelPeb1.Caption;
end;

procedure TForm1.ManageEnabling(lValue: Boolean);
begin
BitBtn1.Enabled := lValue;
BitBtn2.Enabled := lValue;
BitBtn3.Enabled := lValue;
Labelbtn.Enabled := lValue;
BitBtnResign.Enabled := lValue;
GroupBox1.Enabled := lValue;
if (RemainPebs < 3) and (RemainPebs > 0) and lValue then
begin
if RemainPebs < 3 then
BitBtn3.Enabled := False;
if RemainPebs < 2 then
BitBtn2.Enabled := False;
end

end;

procedure TForm1.Finish;
begin
LabelTotPlayed.caption := intToStr(PlayedGames);
LabelIWon.caption := intToStr(ComputerWon);
LabelYouWon.caption := intToStr(PlayedGames - ComputerWon);
DispPebbles(strToInt(ComboBox1.Items[ComboBox1.ItemIndex]));
totPebs := strtoint(LabelPeb1.Caption);
RemainPebs := totPebs;
ManageEnabling(True);
ComboBox1.Enabled := True;
Labelbtn.Enabled := False;
BitBtnResign.Enabled := False;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
DispPebbles(strToInt(ComboBox1.Items[ComboBox1.ItemIndex]));
totPebs := strtoint(LabelPeb1.Caption);
RemainPebs := totPebs;
end;

procedure TForm1.Messaging(const lost: Boolean; const resigning: Boolean);
begin
inc(PlayedGames);
MESSAGEBEEP(0);
if lost then
begin
if resigning then
showmessage('I Resign ! You won the game again !!')
else
showmessage('Congratulations ! You won !! I acknowledges defeat !');
end
else
begin
inc(ComputerWon);
showmessage('Hi !  You lost ! I WON THIS GAME !!');
end;
Finish;
end;

procedure TForm1.LearnByMistakes;
var
x, PageNum, LineNum, nTemp, nTakes: integer;
begin
if RemainPebs <= 0 then
begin
//Openent drew the last pebble(s) ! Computer won !!
//DispPebbles(0);
Messaging(False, False);
exit;
end;
nTemp := random(6) + 1;
PageNum := RemainPebs mod 4;
if PageNum = 0 then
PageNum := 4;
for x := 1 to 3 do
begin
LineNum := aPermutations[nTemp, x];
if (aPages[PageNum, LineNum] > 0) then
break;
end;
if x > 3 then {No unmarked instructions remained ! All are redmarked !!}
begin
// The effect of this move was unknown previously. But it proved to be fatal this time !
// RedMark This oldLineNum of this oldPageNum !
aPages[OldPageNum, OldLineNum] := -99;
// Lost with Resigning Message !
ListBox1.Items.add(intTostr(nTurn) + '. I resigned ');
DispPebbles(RemainPebs);
Messaging(True, True);
exit;
end;
nTakes := aPages[PageNum, LineNum];
if nTakes >= RemainPebs then
begin
ListBox1.Items.add(intTostr(nTurn) + '. I (Computer): ' + intTostr(RemainPebs));
//I am the last drawer and I lost !!
aPages[PageNum, LineNum] := -99;
DispPebbles(0);
Messaging(True, False);
exit;
end;
ListBox1.Items.add(intTostr(nTurn) + '. I (Computer): ' + intTostr(nTakes));
showmessage('I (Computer) take: ' + IntTostr(nTakes) +
' Pebble(s) for this turn !');
OldPageNum := PageNum;
oldLineNum := LineNum;
RemainPebs := RemainPebs - nTakes;
ManageEnabling(True);
DispPebbles(RemainPebs);
end;

procedure TForm1.BitBtnResignClick(Sender: TObject);
begin
inc(PlayedGames);
inc(ComputerWon);
inc(nTurn);
Finish;
end;

procedure TForm1.LabelbtnClick(Sender: TObject);
begin
BitBtnResign.SetFocus;
BitBtnResign.Click;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var
nTaken: Integer;
begin
with Sender as TBitBtn do
nTaken := Tag;
ManageEnabling(False);
if (RemainPebs = totPebs) then
begin
ComboBox1.Enabled := False;
ListBox1.Clear;
nTurn := 1;
end
else
inc(nTurn);
ListBox1.Items.add(intTostr(nTurn) + '. You: ' + intTostr(nTaken));
RemainPebs := RemainPebs - nTaken;
DispPebbles(RemainPebs);
LearnByMistakes;
end;

end.

A zipped file game.zip contains all stuffs (forms, units and project file) of the running project of this game. This project was compiled and run with Delphi - 3.

At last for the interested friends:
I have programmed a game of strategic thinking using the principles of Artificial Intelligence.  The game is somehow like Chess.
The game was programmed using PowerBasic and Assembly Language. This game has won the First Prize in The First All Nepal Software Competition, SOFTWARE MEET 2000. The game can be downloaded at: http//:www.viewnepal.com/gamezip.exe (a self extracting pkzip file). I will be glad to provide a copy through e-mail if the download does not work.

For users, who are interessted in Artificical intelligence: You can find a Delphi component for ArtificialNeuronalNetworks under http://www.logiware.de/ann

## 2009. október 14., szerda

### Bytes to file size

Problem/Question/Abstract:

How I can convert bytes to file size in KB/MB like in windows explorer

function FileSizeStr(Size: LongInt): string;
begin
if Size < 1000 then
Result := IntToStr(Size) + ' B'
else if Size < 102400 then
Result := IntToStr((Size + 1023) shr 10) + ' KB'
else
Result := IntToStr((Size + 1048575) shr 20) + ' MB';
end;

## 2009. október 13., kedd

### How to calculate the elapsed time between 2 DateTime fields

Problem/Question/Abstract:

Using Delphi 5, I need to calculate the elapsed time between 2 DateTime fields with the result returned in Days, Hours and Minutes format.

Subtract the values AsDateTime and then use DecodeDate and DecodeTime on the result:

procedure TMyForm.Button1Click(Sender: TObject);
var
StartT, EndT, DeltaT: TDateTime;
Days, Hour, Min, Sec, MSec: Word;
begin
StartT := StrToDateTime('27.02.2000 13:45');
EndT := StrToDateTime('02.03.2000 17:30');
DeltaT := EndT - StartT;
Days := trunc(DeltaT);
DecodeTime(DeltaT, Hour, Min, Sec, MSec);
ShowMessage(' Time elapsed: ' + IntToStr(Days) + ' days, ' + IntToStr(Hour) +
' hours, ' + IntToStr(Min) + ' minutes ');
end;

When trying to actually run the above sample, you have to change the string constants used to initialize the datetime vars according to your settings in ShortDateFormat and LongTimeFormat.

## 2009. október 12., hétfő

### How to change the default button in a MessageDlg

Problem/Question/Abstract:

How to change the default button in a MessageDlg

function DefMessageDlg(const aCaption: string; const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; DefButton: Integer; HelpCtx: Longint): Integer;
var
i: Integer;
btn: TButton;
begin
with CreateMessageDialog(Msg, DlgType, Buttons) do
try
Caption := aCaption;
HelpContext := HelpCtx;
for i := 0 to ComponentCount - 1 do
begin
if Components[i] is TButton then
begin
btn := TButton(Components[i]);
btn.Default := btn.ModalResult = DefButton;
if btn.Default then
ActiveControl := Btn;
end;
end;
Result := ShowModal;
finally
Free;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if DefMessageDlg('Please confirm', 'Do you want to format your harddisk now?', mtConfirmation, mbYesNoCancel, mrno, 0) = mrYes then
ShowMessage('Formatting disk...');
end;

## 2009. október 11., vasárnap

### How to hide the caret in a TEdit

Problem/Question/Abstract:

Does anyone know how I might be able to suppress the text cursor in a TEdit, so it's not visible?

For that you need to call the HideCaret API function after the control has processed the WM_SETFOCUS message. The OnEnter event is a tad too early for that, so if you do not want to create a TEdit descendent with an overriden message handler for WM_SETFOCUS you need to delay the action by posting a message to the form and have the handler for that message do the HideCaret.

The three edits on this example form share the same OnEnter handler (AllEditEnter), have ReadOnly = true and AutoSelect = false.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, stdctrls, jpeg;

const
UM_HIDECARET = WM_USER + 101;
type
TUMHideCaret = packed record
msg: Cardinal;
control: TWinControl;
end;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
procedure AllEditEnter(Sender: TObject);
private
{ Private declarations }
procedure UMHideCaret(var msg: TUMHideCaret); message UM_HIDECARET;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{\$R *.dfm}

procedure TForm1.AllEditEnter(Sender: TObject);
begin
PostMessage(handle, UM_HIDECARET, wparam(sender), 0);
end;

procedure TForm1.UMHideCaret(var msg: TUMHideCaret);
begin
HideCaret(msg.control.Handle);
end;

end.

Of course this is an excellent way to confuse the user, since there will be no indication where the focus is anymore when the user tabs into one of the edits...

## 2009. október 10., szombat

### How to implement delayed autotyping in a TDBEdit or TEdit

Problem/Question/Abstract:

Using a TDBEdit, I would like to achieve something like this on user input:
S ... (wait a few milliseconds) ... O ... (wait) ... M ... (wait) ... E

procedure SendtextToControl(control: TWinControl; const S: string; interval: Integer {milliseconds});
var
i: Integer;
begin
for i := 1 to Length(S) do
begin
control.perform(WM_CHAR, Ord(S[i]), 0);
control.Update;
if i < Length(S) then
Sleep(interval);
end;
end;

## 2009. október 9., péntek

### How to assign a system variable to a Session.PrivateDir

Problem/Question/Abstract:

On a terminal server I have a login script, which creates a temporary folder (c:\Temp\OfficeTemp\%username%) for each user that logs in. The system variable name is "OfficeTemp". So how do I assign this system variable to Session.PrivateDir? I tried Session.PrivateDir := 'OfficeTemp'; but this did not work. If I explicitly hardcode to := ''C:\temp\OfficeTemp\darshak' it works, but then I am back to my problem of share violation with multiple database, because all the temp files (all users) get created on that folder.

function GetPESEnvironmentValue(pesVarName: string): string;
var
lth: integer;
begin
lth := GetEnvironmentVariable(@pesVarName[1], nil, 0);
if lth > 0 then
begin
SetLength(result, lth);
GetEnvironmentVariable(@pesVarName[1], @result[1], lth);
end
else
result := '';
end;

Session.PrivateDir := GetPESEnvironmentValue('OfficeTemp');

## 2009. október 8., csütörtök

### Drag and Drop from FileManager

Problem/Question/Abstract:

Drag and Drop from FileManager

You need to use these 3 functions from the ShellApi:

DragAcceptFiles - registers whether a window accepts dropped files
DragQueryFile - retrieves the filename of a dropped file
DragFinish - releases memory allocated for dropping files

uses
ShellApi;

..

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, true);
Application.OnMessage := AppMessage;
end;

{ message handler procedure }
// Delphi 1: type DWord = longint; .. FileIndex := -1;

procedure TForm1.AppMessage(var Msg: Tmsg; var Handled: Boolean);
const
BufferLength: DWORD = 511;
var
DroppedFilename: string;
FileIndex: DWORD;
NumDroppedFiles: DWORD;
pDroppedFilename: array[0..511] of Char;
DroppedFileLength: DWORD;
begin
if Msg.message = WM_DROPFILES then
begin
FileIndex := \$FFFFFFFF;
NumDroppedFiles := DragQueryFile(Msg.WParam, FileIndex,
pDroppedFilename, BufferLength);

for FileIndex := 0 to (NumDroppedFiles - 1) do
begin
DroppedFileLength := DragQueryFile(Msg.WParam, FileIndex,
pDroppedFilename, BufferLength);
DroppedFilename := StrPas(pDroppedFilename);

{ process the file name you just received }
end;
DragFinish(Msg.WParam); { important to free memory }
Handled := true;
end;
end;

Notes:

When dropping files, the DroppedFilename is the complete path, not just the filename.ext
It is possible to drag and drop just a directory. So if you are expecting filenames, you have to check for existence yourself.
The filenames come in uppercased.

## 2009. október 7., szerda

### Make the cell of a TStringGrid flash when its value changes

Problem/Question/Abstract:

I want the cell in a TStringGrid to flash for a few seconds when its value changes (as a result of some outside monitored process for example). How would I do that?

One way would be to check the contents of the cell against the previous value in the OnDrawCell event. When it has changed, start a timer which invalidates the grid on a set interval. Below you'll find an example for just one cell.

{Somewhere in the private section of the form}
var
FToggleCount: integer;
FCheckstring: string;

implementation

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Inc(FToggleCount);
if FToggleCount >= 10 then
Timer1.Enabled := False;
StringGrid1.Invalidate;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
s: string;
begin
if (ACol = 1) and (ARow = 1) then
with Sender as TStringGrid do
begin
s := Cells[ACol, ARow];
if s <> FCheckstring then
begin
FCheckstring := s;
FToggleCount := 0;
Timer1.Enabled := True;
end;
if Timer1.Enabled and ((FToggleCount mod 2) = 0) then
begin
Canvas.Brush.Color := clRed;
Canvas.FillRect(Rect);
Canvas.TextOut(Rect.Left + 2, Rect.Top + 2, s);
end;
end;
end;

## 2009. október 6., kedd

### How to split and join a file using TFileStream

Problem/Question/Abstract:

How to split and join a file using TFileStream

{Procedure Splitfile
Parameters:
sourcefilename: name of file to split
blocksize: maximum size of the parts to create

Call method:
static

Description:

Will split the passed file into partial files with a size of blocksize bytes (the last one may be smaller). The names of the files are created from the sourcefilename by replacing the extension with a number, .000, .001 etc. The files can be concatenated using the DOS Copy command with the /b switch to regenerate the original file.

Error Conditions:
I/O errors will raise exceptions.

Created: 03.03.98 by P. Below}

procedure Splitfile(const sourcefilename: string; blocksize: Longint);
var
targetfilename: string;
filecounter: Integer;
bytesRemaining, bytesToWrite: LongInt;
source, target: TFileStream;
begin
if not FileExists(sourcefilename) or (blocksize < = 0) then
Exit;
source := TFileStream.Create(sourcefilename, fmOpenRead or fmShareDenyNone);
try
filecounter := 0;
bytesRemaining := source.Size;
while bytesRemaining > 0 do
begin
targetfilename := ChangeFileExt(sourcefilename, Format('.%.3d', [filecounter]));
if blocksize < bytesRemaining then
bytesToWrite := blocksize
else
bytesToWrite := bytesRemaining;
target := TFileStream.Create(targetfilename, fmCreate);
try
target.CopyFrom(source, bytesToWrite);
bytesRemaining := bytesRemaining - bytesToWrite;
Inc(filecounter);
finally
target.Free;
end;
end;
finally
source.Free;
end;
end;

## 2009. október 5., hétfő

### Highlight the current cell in a TStringGrid

Problem/Question/Abstract:

How to highlight the current cell in a TStringGrid

You solve your problem by using a handler for the grids OnDrawCell event. There you draw both cell background and text when the cell is in the column or row of the selected cell. You also need a handler for OnSelectCell. Here you invalidate the row and column for the old selected cell (still indicated by the grids Col and Row property) and then you invalidate the row and column for the newly selected cell (indicated by the handlers aCol and arow parameters). The TStringGrid class inherits some protected methods from its ancestors which you need for this task. These are InvalidateRow and InvalidateCol. You get at them using a cracker class.

type
TGridCracker = class(TStringgrid);

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
grid: TStringGrid;
begin
grid := Sender as TStringGrid;
if not (gdfixed in State) and ((grid.row = arow) or (grid.col = acol)) then
begin
with grid.canvas do
begin
brush.color := clYellow;
if gdSelected in State then
Font.color := clBlue
else
Font.color := clBlack;
Fillrect(rect);
TextRect(Rect, Rect.left + 2, rect.top + 2, grid.Cells[acol, arow]);
end;
end;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
ARow: Integer; var CanSelect: Boolean);
begin
with TGridCracker(Sender as TStringGrid) do
begin
{redraw column and row if currently selected cell}
Invalidaterow(row);
Invalidatecol(col);
{redraw column and row of new selected cell}
Invalidaterow(arow);
Invalidatecol(acol);
end;
end;

## 2009. október 4., vasárnap

### Access components by their name property

Problem/Question/Abstract:

How to access components by their name property

The following example uses the FindComponent method of Form1 to disable the first 10 SpeedButtons by name:

for i := 1 to 10 do
with Form1.FindComponent('SpeedButton' + IntToStr(i)) as TSpeedButton do
Enabled := False;

## 2009. október 3., szombat

### How to play an AVI file from a resource DLL

Problem/Question/Abstract:

I have an AVI as a resource that I want to play using TAnimate. In a standalone executable this works fine, but fails with a "Cannot Open AVI." error message. According to MSDN I should set the TAnimate ResHand to the instance handle of the DLL. How do I find this?

It appears that trying to load an AVI from a resource causes an exception on the first attempt, so I gave it another go and it worked. Here's the code:

procedure TSplash.ShowSplash;
var
ResHandle: Integer;
begin
try
{ causes exception }
except
{ this time it works }
end;
if ResHandle > 0 then
begin
Animate1.Visible := True;
Animate1.Repetitions := -1;
Animate1.Active := True
end
else
begin
Animate1.Visible := False;
Animate1.Active := False;
{ Show a static bitmap or something if AVI cannot be displayed }
end;
Show;
end;

ResourceName: string): Integer;
var
ResourceHandle: THandle;
begin
TAnimate(AviName).ResName := ResourceName;
TAnimate(AviName).ResHandle := ResourceHandle;
FreeLibrary(ResourceHandle);
result := ResourceHandle;
end;

## 2009. október 2., péntek

### Interbase Object for executing all the Interbase commands at Run time

Problem/Question/Abstract:

How can I create Interbase database at run time? How can I change Interbase database password/user without using Interbase utilities?

If an application runs on an interbase database, the database and all the required objects such as functions, stored procedures etc. has to be created before running the application.

And some of the commands such as changing the Administrators name and password has to be done either using Server manager of Interbase or by the command line utilities supplied by Interbase.

By including this unit in the project, You can execute all the required commands such as creating a database, changing the administrators password, creating shadows, functions, procedures etc.

Make sure that this object is created first in your application. In your project source file the unit "Object_Interbase" must be the first unit to follow after the standard units used by the application.

Include the Object_Interbase unit in your unit's uses cluase from which you are going to use the object. You will be able to get the variable named "ThisDataBase" of Class TMyIbDataBase which we will be using to executing the Interbase commands.

//*** THE UNIT STARTS HERE

unit Object_Interbase;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Registry, IBDataBase, IBQuery, FileCtrl;

type

TMyIbDataBase = class(TObject)
private
//User Defined Type Variable

//Components Variables
FDataBase: TIBDatabase;
FTransaction: TIBTransaction;
FQuery: TIBQuery;

//Boolean Variables
FUseDefaultFiles: Boolean;
FConnected: Boolean;

//String Variables
FIBServerPath: string;
FDatabaseName: string;

//Procedures
procedure CheckDirPath(var Value: string);
procedure ChangetoIBDir;
procedure CreateComponents;
procedure InitilizeVariables;
procedure SetDataBasePath(Value: string);
procedure SetDatabaseName(Value: string);
protected
public
constructor Create;

//Procedures
procedure IBCreateDatabase;
procedure IBConnectToDatabase;
procedure IBDisConnecFromDatabase;
procedure IBQueryAssisnSQL(Value: string; CloseAfterExecution: Boolean);

//Component Properties

//User Defined Type Properties

//Boolean value Properties
property IBConnected: Boolean read FConnected default False;
property IBExists: Boolean read FUseDefaultFiles default False;

//String Value Properties
property IBDatabasePath: string read FDataBasePath write SetDataBasePath;
property IBDatabaseName: string read FDatabaseName write SetDatabaseName;
end;

var
ThisDataBase: TMyIbDataBase;

implementation

{ TIbDataBase }

procedure TMyIbDataBase.CheckDirPath(var Value: string);
begin
if Value[Length(Value)] <> '\' then
Value := Value + '\';
if not DirectoryExists(Value) then
begin
CreateDir(Value);
end;
end;

var
I: Integer;
begin
ThisDataBase.ChangetoIBDir;
I := WinExec(pchar('gsec -user ' + ThisDataBase.IBUserName +
' -mo ' + ThisDataBase.IBUserName + ' -pw ' +
Value), 0);
end;

procedure TMyIbDataBase.ChangetoIBDir;
begin
if ThisDataBase.IBExists then
ChDir(ThisDataBase.IBServerPath);
end;

procedure TMyIbDataBase.IBConnectToDatabase;
begin
if not ThisDataBase.IBConnected then
begin
FDataBase.Close;
FDataBase.SQLDialect := 1;
FTransaction.Active := False;
FQuery.Close;
FDataBase.Params.Clear;
FDataBase.DatabaseName := ThisDataBase.IBDatabasePath + IBDatabaseName;
try
FDataBase.Connected := True;
FTransaction.DefaultDatabase := FDataBase;
except
end;
FConnected := FDataBase.Connected;
FQuery.Transaction := FTransaction;
FQuery.Database := FDataBase;
FDataBase.DefaultTransaction := FTransaction;
if FConnected then
begin
FTransaction.Active := True;
end;
end;
end;

constructor TMyIbDataBase.Create;
begin
CreateComponents;
InitilizeVariables;
end;

procedure TMyIbDataBase.CreateComponents;
begin
FDataBase := TIBDatabase.Create(Application);
FTransaction := TIBTransaction.Create(Application);
FDataBase.DefaultTransaction := FTransaction;
FTransaction.DefaultDatabase := FDataBase;
FQuery := TIBQuery.Create(Application);
FQuery.Database := FDataBase;
FQuery.Transaction := FTransaction;
FQuery.ParamCheck := False;
end;

procedure TMyIbDataBase.IBCreateDatabase;
var
vmem: TStringList;
S: string;
begin
S := ExtractFilePath(Application.ExeName);
vmem := TStringList.Create;
vmem.Add('Create database "' + ThisDataBase.IBDatabasePath +
ThisDataBase.IBDatabaseName +
vmem.Add('gfix -w "sync" -user "' + ThisDataBase.IBUserName + '" -pa ' +
ThisDataBase.IBPassword + '" "' + ThisDataBase.IBDatabasePath +
ThisDataBase.IBDatabaseName + '"');
S := S + 'Sql03EASY05.Sql';
vmem.SaveToFile(S);
vmem.Free;
ThisDataBase.ChangetoIBDir;
S := 'isql -input ' + S;
winexec(pchar(S), 0);
DeleteFile(S);
S := ThisDataBase.IBDatabasePath + ThisDataBase.IBDatabaseName;
while not FileExists(S) do
;
ThisDataBase.IBConnectToDatabase;
FConnected := FDataBase.Connected;
end;

var
S, vFname: string;
begin
if ThisDataBase.IBConnected then
begin
case FShdType of
stAuto: S := 'Auto';
stManual: S := 'Manual';
stConditional: S := 'Conditional';
end;
vFname := Copy(FDatabaseName, 1, pos('.', FDatabaseName)) + 'Shd';
FQuery.Close;
FQuery.SQL.Clear;
FQuery.SQL.Text := 'Create Shadow 1 ' + S + ' "' + FShadowPath +
vFname + '" Length = 10000';
FQuery.ExecSQL;
Application.ProcessMessages;
end;
end;

procedure TMyIbDataBase.InitilizeVariables;
begin
FDataBasePath := '';
FIBServerPath := '';
FUser := '';
FDatabaseName := '';
FShdType := stConditional;
FConnected := False;
end;

var
vReg: TRegistry;
begin
vReg := TRegistry.Create;
vReg.RootKey := HKEY_LOCAL_MACHINE;
if vReg.OpenKey('\Software\InterBase Corp\InterBase\CurrentVersion', False) then
begin
FUseDefaultFiles := True;
end
else
begin
FIBServerPath := ExtractFilePath(Application.ExeName);
FUseDefaultFiles := False;
end;
vReg.CloseKey;
vReg.Free;
end;

begin
if (Value <> FUser) then
FUser := Value;
end;

begin
end;

procedure TMyIbDataBase.SetDatabaseName(Value: string);
begin
if (Value <> FDatabaseName) then
FDatabaseName := Value;
end;

procedure TMyIbDataBase.SetDataBasePath(Value: string);
begin
if (Value <> FDataBasePath) then
begin
FDataBasePath := Value;
CheckDirPath(FDataBasePath);
end;
end;

begin
end;

begin
begin
end;
end;

begin
if (Value <> FShdType) then
FShdType := Value;
end;

procedure TMyIbDataBase.IBQueryAssisnSQL(Value: string; CloseAfterExecution: Boolean);
begin

FQuery.Close;
FQuery.SQL.Clear;
FQuery.SQL.Text := Value;
try
FQuery.ExecSQL;
except
end;
if CloseAfterExecution then
begin
FQuery.Close;
FQuery.SQL.Clear;
FQuery.SQL.Text := 'Commit';
FQuery.ExecSQL;
FQuery.Close;
end;
end;

procedure TMyIbDataBase.IBDisConnecFromDatabase;
begin
FDataBase.CloseDataSets;
FDataBase.ForceClose;
FConnected := FDataBase.Connected;
end;

initialization
if (ThisDataBase = nil) then
ThisDataBase := TMyIbDataBase.Create;
finalization
if (ThisDataBase <> nil) then
begin
ThisDataBase.Free;
ThisDataBase := nil;
end;
end.

//** THE UNIT ENDS HERE

Examples:

1. Creating a Database

If you want to create a database called "Sample.Gdb" in the directory called "c:\test\" with the administrator named
"LION" with the password "king". Just by using the properties and methods of this simple object we can create the database.

ThisDataBase.IBDatabasePath := 'c:\test\';
ThisDataBase.IBDatabaseName := 'Sample.Gdb';
ThisDataBase.IBCreateDatabase;

ThisDataBase.IBConnectToDatabase;

4. Creating a Table

ThisDatabase.IBQueryAssisnSQL('CREATE TABLE USERS(                    ' +
'USERCODE      VARCHAR(6)  NOT NULL   , ' +
'USERNAME      VARCHAR(20) NOT NULL   , ' +
'USERACTIVE    VARCHAR(1)  DEFAULT "Y", ', True);

In the same way you can assign the scripts for creating the stored procedures, function and the scripts for creating all the objects using this method.

5. The properties  IBAppDatabase, IBAppTransaction and IBAppQuery can be used to assign to the properties of the IBTable component if you are go to work with the IBTable component.

If in case you are not going to work with the Interbase components this object can be modifed to work with the simple database components.

## 2009. október 1., csütörtök

### Disabling a TMemo without getting gray text

Problem/Question/Abstract:

I want to set Enabled=False in my TMemo, but I don't want the text to turn gray.

OPTION 1:

Ok, this is a dirty trick. But is works fine for me.

Set the Enabled to True (yes realy).
In the OnEnter event of your memo put:

procedure TForm1.MyMemoEnter(Sender: TObject);
begin
SomeOtherControl.SetFocus;
end;

Now, focus will be forced to some other control every time your user tries to fucus on your memo. To the user it seems that the memo is disabled.

OPTION 2:

This one is much simpler:
Put the memo on a panel. Then set Panel.Enabled=False.
Ok, this works if you can put the memo on a panel. Just with inherited forms you can get into some trouble. But is should work for most people.