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.

Answer:

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
  { ... }
  SetGraphicsMode(aCanvas.Handle, GM_Advanced);
  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;

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?

Answer:

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';
VDoc.CustomDocumentProperties.Add(PropName, False, msoPropertyTypeString,
  'Utter drivel', EmptyParam);
{ Read a document property }
Caption := VDoc.CustomDocumentProperties[PropName].Value;
{ ... }

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 (:-

Answer:

For those of you who don't know why u should not use the standard dataset.recordcount when developing client server database applications.
This article is especialy for those cs db apps against a sqlserver 7 db.

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...)

Set system date and time

Problem/Question/Abstract:

Set system date and time

Answer:

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;

Determining the associated application

Problem/Question/Abstract:

How can I get the application associated with a document?

Answer:

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 := '';
  if Reg.OpenKeyReadOnly(ExtractFileExt(DocFileName)) then
  begin
    FileClass := Reg.ReadString('');
    Reg.CloseKey;
  end;
  if FileClass <> '' then
  begin
    if Reg.OpenKeyReadOnly(FileClass + '\Shell\Open\Command') then
    begin
      Result := Reg.ReadString('');
      Reg.CloseKey;
    end;
  end;
  Reg.Free;
end;

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

Clear all edit controls on your form

Problem/Question/Abstract:

Clear all edit controls on your form

Answer:

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;

BDE alias info

Problem/Question/Abstract:

BDE alias info

Answer:

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;

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

Answer:

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);
  if Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then
  begin
    // if current record is modified
    if DataLink.DataSet.UpdateStatus = usModified then
    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.
    else if DataLink.DataSet.UpdateStatus = usInserted then
    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.
    else if DataLink.DataSet.UpdateStatus = usDeleted then
    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);

  if Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then
  begin
    // if current record is modified.
    if DataLink.DataSet.UpdateStatus = usModified then
    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.
    else if DataLink.DataSet.UpdateStatus = usInserted then
    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.
    else if DataLink.DataSet.UpdateStatus = usDeleted then
    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.
  if Assigned(DataLink) and Assigned(DataLink.DataSet) and (DataLink.Active) then
  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.

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?

Answer:

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.

How to colorize an image

Problem/Question/Abstract:

How to colorize an image

Answer:

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;

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...

Answer:

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
  I: HMenu;
begin
  I := GetSystemMenu(Handle, False);
  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.

A Simple Property Editor

Problem/Question/Abstract:

How can I create a simple property editor?

Answer:

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;
  constructor Create(ADesigner: TFormDesigner; APropCount: 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 Designer: TFormDesigner read FDesigner;
  property PrivateDirectory: string read GetPrivateDirectory;
  property PropCount: Integer read FPropCount;
  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.

How to detect if DCOM is installed

Problem/Question/Abstract:

How to detect if DCOM is installed

Answer:

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

How to read the file header of a wave file

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?

Answer:

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


type
  TWaveHeader = record
    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:


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

  try
    f := TFileStream.create(Filename, fmOpenRead);
    f.Read(w, Sizeof(w)); //Reading the file header

    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;



I hope this example will help you to work with wave files in your application.

Delete the row in TStringGrid component

Problem/Question/Abstract:

How can I delete the row in TStringGrid component?

Answer:

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;

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?

Answer:

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 S: string); overload;
    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;
    property Token: string read FToken;
  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;
    property OnParseProperty: TParsePropertyEvent read FParsePropertyEvent
      write FParsePropertyEvent;
  end;

  EDFMParserError = class(Exception);

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

  TTranslationParser = class(TBaseParser)
  private
    FTranslationItemEvent: TTranslationItemEvent;
    procedure ParseStringConstant;
    procedure SkipWhitespaceAndComments;
    procedure DoTranslationItem(const name, value: string);
  public
    constructor Create(const S: string); override;
    procedure Parse; override;
    property OnTranslationItem: TTranslationItemEvent read FTranslationItemEvent
      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
    Error('Expected string "%s" not found', [s]);
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
    NextChar; {skip leading quote}
    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
        Error('Malformed $IFDEF...$ELSE encountered, $ELSE not found');
      Delete(lS, 1, n2 - 1);
      Inc(n1, n2 - 1);
      {look for the $ENDIF}
      n2 := Pos('{$endif}', lS);
      if n2 = 0 then
        Error('Malformed $IFDEF...$ENDIF encountered, $ENDIF not found');
      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
          Error('Malformed $IFDEF...$ENDIF encountered, $ENDIF not found');
        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
  SkipWhitespaceAndComments;
  if EndOfText then
    Exit;
  NextToken;
  name := Token;
  SkipWhitespaceAndComments;
  if EndOfText then
    Exit;
  if CurrentChar <> '=' then
    Error('Expected: =, found "%s"', [CurrentChar]);
  NextChar;
  SkipWhitespaceAndComments;
  if EndOfText then
    Exit;
  value := ParseStringValue;
  SkipWhiteSpace;
  if not EndOfText and (CurrentChar = ';') then
    NextChar;
  DoTranslationItem(name, value);
end;

procedure TTranslationParser.SkipWhitespaceAndComments;
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
  if locale = GetThreadLocale then
    Exit
  else
    Locale := GetThreadLocale;
  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.

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 !)

Answer:

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 !!
    // RedMark This LineNum of this PageNum !
    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);
  ListBox1.Items.add(intTostr(nTurn) + '. You resigned');
  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

Component Download: game.zip

Bytes to file size

Problem/Question/Abstract:

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

Answer:

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;

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.

Answer:

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.

How to change the default button in a MessageDlg

Problem/Question/Abstract:

How to change the default button in a MessageDlg

Answer:

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;

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?

Answer:

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...

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

Answer:

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;

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.

Answer:

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');

Drag and Drop from FileManager

Problem/Question/Abstract:

Drag and Drop from FileManager

Answer:

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.

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?

Answer:

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;

How to split and join a file using TFileStream

Problem/Question/Abstract:

How to split and join a file using TFileStream

Answer:

{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;

Highlight the current cell in a TStringGrid

Problem/Question/Abstract:

How to highlight the current cell in a TStringGrid

Answer:

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;

Access components by their name property

Problem/Question/Abstract:

How to access components by their name property

Answer:

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;

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?

Answer:

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
    ResHandle := LoadAviAsResource(Animate1, 'MyDll.dll', 'SPLASHAVI');
    { causes exception }
  except
    ResHandle := LoadAviAsResource(Animate1, 'MyDll.dll', 'SPLASHAVI');
    { 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;

function TSplash.LoadAviAsResource(const AviName: TObject; DllName,
  ResourceName: string): Integer;
var
  ResourceHandle: THandle;
begin
  ResourceHandle := LoadLibrary(Pchar(DllName));
  TAnimate(AviName).ResName := ResourceName;
  TAnimate(AviName).ResHandle := ResourceHandle;
  FreeLibrary(ResourceHandle);
  result := ResourceHandle;
end;

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?

Answer:

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
  TShadow = (stManual, stAuto, stConditional);

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

    FShdType: TShadow;

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

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

    //String Variables
    FIBServerPath: string;
    FDataBasePath, FShadowPath: string;
    FUser, FPassword: string;
    FDatabaseName: string;

    //Procedures
    procedure CheckDirPath(var Value: string);
    procedure ChangetoIBDir;
    procedure CreateComponents;
    procedure InitilizeVariables;
    procedure IBLoadpathfromRegistry;
    procedure SetDataBasePath(Value: string);
    procedure SetShadowPath(Value: string);
    procedure SetAdminName(Value: string);
    procedure SetAdminPassword(Value: string);
    procedure SetDatabaseName(Value: string);
    procedure SetShadow(Value: Boolean);
    procedure SetShadowType(Value: TShadow);
  protected
  public
    constructor Create;

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

    //Component Properties
    property IBAppDatabase: TIBDatabase read FDataBase;
    property IBAppTransaction: TIBTransaction read FTransaction;
    property IBAppQuery: TIBQuery read FQuery;

    //User Defined Type Properties
    property IBShadowType: TShadow read FShdType write SetShadowType;

    //Boolean value Properties
    property IBConnected: Boolean read FConnected default False;
    property IBExists: Boolean read FUseDefaultFiles default False;
    property IBShadow: Boolean read FShadow write SetShadow default False;

    //String Value Properties
    property IBServerPath: string read FIBServerPath;
    property IBUserName: string read FUser write SetAdminName;
    property IBPassword: string read FPassword write SetAdminPassword;
    property IBDatabasePath: string read FDataBasePath write SetDataBasePath;
    property IBShadowPath: string read FShadowPath write SetShadowPath;
    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;

procedure TMyIbDataBase.IBChangeAdminPassword(Value: string);
var
  I: Integer;
begin
  ThisDataBase.ChangetoIBDir;
  I := WinExec(pchar('gsec -user ' + ThisDataBase.IBUserName +
    ' -password ' + ThisDataBase.IBPassword +
    ' -mo ' + ThisDataBase.IBUserName + ' -pw ' +
    Value), 0);
  ThisDataBase.IBPassword := Value;
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.LoginPrompt := False;
    FDataBase.Params.Clear;
    FDataBase.Params.Add('USER_NAME=' + ThisDataBase.IBUserName);
    FDataBase.Params.Add('PASSWORD=' + ThisDataBase.IBPassword);
    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;
  IBLoadpathfromRegistry;
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 +
    '" user "' + ThisDataBase.IBUserName + '" password "' +
    ThisDataBase.IBPassword + '" page_size=2048 Length=50;');
  vmem.Add('Commit work;');
  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;

procedure TMyIbDataBase.IBCreateShadow;
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 := '';
  FShadowPath := '';
  FIBServerPath := '';
  FUser := '';
  FPassword := '';
  FDatabaseName := '';
  FShdType := stConditional;
  FConnected := False;
end;

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

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

procedure TMyIbDataBase.SetAdminPassword(Value: string);
begin
  if (Value <> FPassword) then
    FPassword := Value;
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;

procedure TMyIbDataBase.SetShadow(Value: Boolean);
begin
  if (Value <> FShadow) then
    FShadow := Value;
end;

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

procedure TMyIbDataBase.SetShadowType(Value: TShadow);
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.IBUserName := 'LION';
ThisDataBase.IBPassword := 'king';
ThisDataBase.IBDatabasePath := 'c:\test\';
ThisDataBase.IBDatabaseName := 'Sample.Gdb';
ThisDataBase.IBCreateDatabase;

The properties IBUserName, IBPassword, IBDatabaseName has to be assigned only once.

2. Creating Shadow

ThisDataBase.IBConnectToDatabase;
ThisDatabse.IBShadowType := stAuto;
ThisDatabse.IBCreateShadow;

3. Changing Database Password

ThisDataBase.IBChangeAdminPassword('NewPassword');

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.

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.

Answer:

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.