Bitmap blending

Problem/Question/Abstract:

How to show an image changing into another.

Answer:

In a previous post I provided a function that takes 2 TBitmap arguments and returns a crossfaded image obtained by combining the two bitmaps.

That can be used to make an animation that shows a bitmap morphing into another bitmap.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Image3: TImage;
esteps: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

function mix(img1, img2: TBitmap; steps, stepno: integer): TBitmap;
var
x, y, height, width: integer;
pimg1, pimg2, pres: PByteArray;
res: TBitmap;
begin
res := TBitmap.Create;
if img1.Height > img2.Height then
height := img2.Height
else
height := img1.Height;
if img1.Width > img1.Width then
width := img2.Width
else
width := img1.Width;

img1.PixelFormat := pf24bit;
img2.PixelFormat := pf24bit;
res.PixelFormat := pf24bit;
res.Width := width;
res.Height := height;

for y := 0 to height - 1 do
begin
pimg1 := img1.ScanLine[y];
pimg2 := img2.ScanLine[y];
pres := res.ScanLine[y];

for x := 0 to width - 1 do
begin
pres^[x * 3] := pimg1^[x * 3] * (steps - stepno) div steps +
pimg2[x * 3] * stepno div steps;
pres^[x * 3 + 1] := pimg1^[x * 3 + 1] * (steps - stepno) div steps +
pimg2[x * 3 + 1] * stepno div steps;
pres^[x * 3 + 2] := pimg1^[x * 3 + 2] * (steps - stepno) div steps +
pimg2[x * 3 + 2] * stepno div steps;
end;
end;
result := res;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
steps, i: integer;
img1, img2: TBitmap;
begin
if esteps.text <> '' then
begin
steps := strtoint(esteps.text);
img1 := TBitmap.Create;
img2 := TBitmap.Create;
img1.LoadFromFile('e:\untitled.bmp');
img2.LoadFromFile('e:\untitled1.bmp');
for i := 1 to steps do
begin
image3.Picture.Bitmap := mix(img1, img2, steps, i);
image3.Refresh;
sleep(30);
end;
img1.Free;
img2.Free;
end
else
messagedlg('Please provide the number of steps for morphing', mterror, [mbok], 0);
end;

end.

I have a form with a button on it, a TImage object and an edit box. The editbox is used to provide the number of steps in wich morphing will occur. I load two bitmaps and the morphing is showed in the TImage object. The function mix is mixing two images in a certain proportion calculated from the values of the steps and stepno.

How to load HTML code from a string into a TWebBrowser

Problem/Question/Abstract:

How to load HTML code from a string into a TWebBrowser

Answer:

First, add ActiveX to the unit's Uses clause.

With this procedure you'll be able to do so.

procedure LoadHTMLCode(WebBrowser: TWebBrowser; HTMLCode: string);
var
sl: TStringList;
ms: TMemoryStream;
begin
WebBrowser.Navigate('about:blank');
while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
Application.ProcessMessages;

if Assigned(WebBrowser.Document) then
begin
sl := TStringList.Create;
try
ms := TMemoryStream.Create;
try
sl.Text := HTMLCode;
sl.SaveToStream(ms);
ms.Seek(0, 0);
(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));
finally
ms.Free;
end;
finally
sl.Free;
end;
end;
end;
An example :
LoadHTMLCode(WebBrowser1,Memo1.Text) ;

InterBase Stored Procedures

Problem/Question/Abstract:

Creating Them and Using Them from Delphi

Answer:

One of the cornerstones of successful client/server programming is the stored procedure. Unfortunately, InterBase stored procedures are woefully underdocumented, especially regarding the Delphi connection. This article attempts to help fill the documentation gap.

This article has two major goals. The first is to provide a general description of an InterBase stored procedure, describe the benefits of stored procedures, and provide specific examples of the more common procedures you'll need to create. The second is to explain how Delphi uses the stored procedures, i.e. explain how they're called.

What Is a Stored Procedure?

A stored procedure is a routine written in InterBase trigger and procedure language (catchy, hunh?) that can be called by a client (e.g. a Delphi application) or another procedure or trigger. Stored procedures can be used for many things, but this article will focus on their use with the mainstay SQL statements: SELECT, INSERT, UPDATE, and DELETE.

Select statements are the most common, so let's tackle them first. A stored procedure that contains a SQL SELECT statement is often referred to as a select procedure.

Stored Procedure Basics

An InterBase stored procedure is created using a CREATE PROCEDURE statement. The code in Figure 1, for example, creates a select procedure named SPS_Address_ProviderID. This straightforward select procedure returns four columns from any Address table row that has a ProviderID column value equal to the ProviderID provided as an input argument.

CREATE PROCEDURE SPS_Address_ProviderID(ProviderID INTEGER)
RETURNS (Address CHAR(60),
City    CHAR(30),
State   CHAR( 2),
ZipCode CHAR( 5))
AS
BEGIN

FOR
SELECT Address, City, State, ZipCode
FROM Address
WHERE ProviderID = :ProviderID
INTO :Address, :City, :State, :ZipCode
DO SUSPEND;

END
Figure 1: An example of a select procedure.

As you can see, a select procedure is essentially a SQL SELECT statement in the form of a function call. Input parameters - if there are any - are included in the CREATE statement as a comma-delimited list within parentheses. There's only one in this example; it's named ProviderID, and is of type INTEGER. The InterBase data types are shown in Figure 2.

Name
Size
Range/Precision
BLOB
variable
None - BLOB segment size is limited to 64KB
CHAR(n)
n characters
1 to 32767 bytes
DATE
64 bits
1 Jan 100 to 11 Dec 5941
DECIMAL(precision, scale)
variable
precision = 1 to 15, least number of precision digits
scale = 1 to 15, number of decimal places
DOUBLE PRECISION
64 bits
1.7 x 10-308 to 1.7 x 10308
FLOAT
32 bits
3.4 x 10-38 to 3.4 x 1038
INTEGER
32 bits
-2,147,483,648 to 2,147,483,648
NUMERIC(precision, scale)
variable
same as DECIMAL
SMALLINT
16 bits
-32768 to 32767
VARCHAR(n)
n characters
1 to 32765 bytes
Figure 2: InterBase data types (based on a chart from the InterBase Workgroup Server Data Definition Guide, pages 46-7).

Any output parameters - and there must be at least one for a select procedure - are described in a RETURNS statement, which also takes the form of a comma-delimited list inside parentheses. In this example, there are four output parameters: Address, City, State, and ZipCode. All are of type CHAR, which is used for strings.

Header and body. The CREATE and RETURNS statements (if RETURNS is present) comprise the stored procedure's header. Everything following the AS keyword is the procedure's body. In this example, the body is contained entirely within the BEGIN and END statements required for every stored procedure.

There can also be statements between the AS and BEGIN keywords that are considered part of the body. These statements declare local variables for the stored procedure; we'll discuss them later, along with the FOR, INTO, and DO SUSPEND statements.

Why Use Them?

They're fast. A query stored on the server as a procedure executes far more quickly than one built and executed on the client. The speed difference is even more pronounced when your database application is running on a LAN or WAN. The main reason is that when the client application sends the query to the server, the server responds with a large amount of metadata (specific database information about the requested query). The query plan is then built, and the query is re-sent to the server for execution.

In contrast, if a stored procedure is used to perform the SQL statement, the client simply requests that the server execute the procedure, and send back the answer set (if any). The result is that just two trips are made between the client and server, instead of four (one of which contains a large amount of data).

They're reusable. In a database application of significant size, you'll find yourself using the same SQL statements (SELECTs, INSERTs, etc.) repeatedly. Rather than recreate a statement on the client each time, it's better to store the statement in the database and call it. It's the same idea as maintaining a library of procedures and functions shared between modules. The benefits are the same, as well: Readability is enhanced, and redundancy, maintenance, and documentation are greatly reduced.

They're part of the database. Although this has been mentioned, it bears repeating that a stored procedure is part of the database. Not only does this make the procedure readily accessible to the database, it also insures that the procedure is syntactically correct, and that the SQL statements included in the procedure are correct. The database will not accept it until it's valid, i.e. the CREATE PROCEDURE statement will fail.

Creating Select Procedures

We'll examine five types of stored procedures:

a SELECT statement that may return multiple rows
a SELECT statement that returns one row, i.e. a singleton select
an INSERT statement
an UPDATE statement
a DELETE statement

Creating a Multi-Row SELECT

When a SELECT statement might return multiple rows, the stored procedure must use the FOR...DO looping construct. We've already seen this in Figure 1:

FOR

SELECT Address, City, State, ZipCode
FROM Address
WHERE ProviderID = :ProviderID
INTO :Address, :City, :State, :ZipCode

DO SUSPEND;

Here a FOR...DO loop has been placed around the SELECT statement. This will cause the SUSPEND command to be executed for each row returned by the SELECT statement. (SQL programmers will recognize this as a fetch loop on an open cursor.)

Fine - but what does SUSPEND do? It's got a lousy name, but a SUSPEND command is absolutely necessary to make the SELECT stored procedure work. It causes the stored procedure to return a value via the variables associated with the INTO clause. (Note: InterBase will accept a stored procedure without a SUSPEND statement, but the stored procedure will never return a value.)

Loading the Output Variables. An additional clause on the SELECT statement may be new to you. The INTO clause describes the variables that will be loaded with the result of the SELECT statement, then returned by the stored procedure via the variables described in the RETURNS statement. They must agree in number, order, and name, or InterBase will not accept the procedure.

A Singleton SELECT

When a SELECT statement will return only one row, there's no need for a FOR...DO loop (see Figure 3). However, it's important to ensure that the SELECT will never attempt to return more than one row, i.e. that the WHERE clause uses a unique row identifier. If InterBase determines that multiple rows are possible, it will not accept the procedure.

SET TERM ^ ;
CONNECT "c:\doj\cmis\cmis.gdb"^

CREATE PROCEDURE SPS_Subject_Confidential(
ProviderID INTEGER)
RETURNS (ConfideCount INTEGER)
AS
BEGIN

SELECT COUNT(*)
FROM Party P, CaseStatus CS, Status S
WHERE P.ProviderID          = :ProviderID
AND CS.ComplaintID        = P.ComplaintID
AND CS.Status             = S.Status
AND S.ConfidentialityFlag = 'T'
AND CS.StatusDate =
( SELECT MAX(StatusDate)
FROM CaseStatus Case
WHERE Case.ComplaintID = P.ComplaintID )
INTO :ConfideCount;

SUSPEND;

END^
SET TERM ; ^
Figure 3: This ISQL script creates a singleton select. This COUNT statement will always return one row, so there is no need for the FOR...DO loop.

The SELECT statement in Figure 3 is returning the result of the aggregate function, COUNT, so it will always return one row. (Incidentally, it also features a sub-select. This type of query is useful in any situation where you need to determine the current status row for something - a "case" in this instance.)

The SELECT statement now requires a terminating semicolon:

INTO :ConfideCount;

as does the one-word SUSPEND statement that immediately follows it.

This is in contrast to the stored procedure shown in Figure 1. It may seem odd, but in the multiple SELECT shown in Figure 1, there's only one statement in the body of the procedure: It's a FOR...DO statement that's terminated just after the SUSPEND command:

DO SUSPEND;

Therefore, there is no terminating semicolon for the SELECT itself.

An INSERT

An INSERT statement is used to add a row to an InterBase table. No RETURNS variable is necessary for an INSERT stored procedure (see Figure 4). Not shown is that an InterBase trigger is using a generator to automatically assign a value to a primary key column - a typical scenario. (These issues are discussed in detail in Bill Todd's article, "InterBase Triggers and Generators.")

SET TERM ^ ;
CONNECT "c:\doj\cmis\cmis.gdb"^

CREATE PROCEDURE SPI_Payment
(
MoneyOwedBMCFID      INTEGER,
AmountPaid           FLOAT,
CheckNumber          CHAR(15),
DateOfCheck          DATE,
DateMoneyReceived    DATE,
DateMoneyDistributed DATE
)
AS
BEGIN

INSERT INTO Payments
(
MoneyOwedBMCFID,
AmountPaid,
CheckNumber,
DateOfCheck,
DateMoneyReceived,
DateMoneyDistributed
)
VALUES
(
:MoneyOwedBMCFID,
:AmountPaid,
:CheckNumber,
:DateOfCheck,
:DateMoneyReceived,
:DateMoneyDistributed
);
END^

SET TERM ; ^
Figure 4: This stored procedure describes a SQL INSERT statement.

An UPDATE

An UPDATE statement is used to modify one or multiple columns of an existing row in an InterBase table. No RETURNS variable is necessary for an UPDATE stored procedure (see Figure 5). However, one or more of the input arguments must be used in a WHERE clause to identify the row to update.

SET TERM ^ ;
CONNECT "c:\doj\cmis\cmis.gdb"^

CREATE PROCEDURE SPU_Penalty
(
PenaltyID       INTEGER,
PartyID         INTEGER,
PenaltyType     CHAR(20),
PenaltyUnitType CHAR(10),
DateOfPenalty   DATE,
PenaltyUnits    INTEGER
)
AS
BEGIN

UPDATE Penalty
SET PartyID
WHERE PenaltyID = :PenaltyID; = :PartyID,
PenaltyType     = :PenaltyType,
PenaltyUnitType = :PenaltyUnitType,
DateOfPenalty   = :DateOfPenalty,
PenaltyUnits    = :PenaltyUnits
END^

SET TERM ; ^
Figure 5: This stored procedure describes a SQL UPDATE statement.

A DELETE

A DELETE statement is used to remove an existing row or rows from an InterBase table. No RETURNS variable is necessary for a DELETE stored procedure (see Figure 6). One or more of the input arguments must be used in a WHERE clause to identify the row(s) to delete.

SET TERM ^ ;
CONNECT "c:\doj\cmis\cmis.gdb"^

CREATE PROCEDURE SPD_LicenseToBill (ProviderID INTEGER)
AS
BEGIN

DELETE FROM LicenseToBill
WHERE ProviderID = :ProviderID;

END^

SET TERM ; ^
Figure 6: This stored procedure describes a SQL DELETE statement.

ISQL Scripts

To add a stored procedure to an InterBase database, you must describe the stored procedure in an ISQL script and then run that script using ISQL. The code examples presented so far are ISQL scripts that must be run through InterBase's interactive interface, ISQL (using the menu command File | Run an ISQL Script). A couple of tricks are required to make these scripts work.

First, although you may already have connected to an InterBase database using ISQL (File | Connect to Database), it is still necessary to explicitly connect each time an ISQL script is executed. This is done with a CONNECT statement; for example:

CONNECT "c:\doj\cmis\cmis.gdb"^

The trouble with terminators. Second, an ISQL script must satisfy two masters: the ISQL tool itself, and the InterBase database it addresses. Both require statement terminators, and both use the semicolon (; ) as their default terminator character. Something's gotta give, so you need to temporarily change the terminator for ISQL. This is done with the SET TERM command. This statement, for example:

SET TERM ^ ;

tells ISQL to use the carat (^ ) character as a terminator until further notice. You can use any character you like as the alternate terminator, but I would highly recommend that you use something unusual. Typically, the last statement in an ISQL script replaces the semicolon as the terminating character.

Calling Stored Procedures from Delphi

Okay, we know how to build the stored procedures. Now how do we call them from Delphi? There are two ways - one is necessary for SELECT statements (i.e. statements that return a value), the other for INSERT, UPDATE, and DELETE statements.

Stored procedures with SELECT statements are called from Delphi using a Query object (of class TQuery). This is despite the fact that we're calling a stored procedure; again, a Delphi Query object is used for any statement that returns the result of a SELECT statement. The other SQL statements - INSERT, UPDATE, and DELETE - are called using a Delphi StoredProc object (of class TStoredProc).

Calling a Select Procedure

We'll describe how stored procedures are called, beginning with a SELECT statement. First, however, let's back up a bit and take a look at how we'd describe and call a "conventional" query (i.e. one not contained in a select procedure) using Object Pascal (see Figure 7).

procedure {... }
var
FetchCount: Word;
QueryAddress: TQuery;
{  ... }

QueryAddress := TQuery.Create(Self);
with QueryAddress do
begin
DatabaseName := 'CMIS_DB';
SQL.Add('SELECT AddressType, Address, City, County,   ');
SQL.Add('       State, ZipCode, ZipPlus4, PhoneNumber');
SQL.Add('  FROM Address                              ');
SQL.Add(' WHERE ProviderID = :ProviderID             ');
ParamByName('ProviderID').AsInteger :=
SubjectUpdateProviderID;
Open;

FetchCount := 0;
while EOF = False do
begin
with StringGridAddress do
begin
RowCount := FetchCount + 1;
Cells[0, FetchCount] := Fields[0].Text;
Cells[1, FetchCount] := Fields[1].Text;
Cells[2, FetchCount] := Fields[2].Text;
Cells[3, FetchCount] := Fields[3].Text;
Cells[4, FetchCount] := Fields[4].Text;
Cells[5, FetchCount] := Fields[5].Text;
Cells[6, FetchCount] := Fields[6].Text;
Cells[7, FetchCount] := Fields[7].Text;
end;
Inc(FetchCount);
Next;
end;

Free;

end;
{ ... }
end;
Figure 7: Describing and executing a SQL SELECT statement with Object Pascal.

First the Query object, QueryAddress, is instantiated, and its Database and SQL properties are assigned values. Then the single query parameter, ProviderID, is assigned a value, and the query is executed using the Open method. In this example, a while loop is used to take the results of the query and load them into a StringGrid component.

All of this is familiar, but how do we change it to call a stored procedure? For this SELECT statement, the changes are fairly minor (see Figure 8). There are two notable differences:

First, the FROM clause now refers to the name of the stored procedure, SPS_Address_ProviderID, not a specific table. (The difference would be more pronounced if there were a list of tables.)
Second, there is no WHERE clause; the WHERE clause is described in the stored procedure. The input parameter is simply placed in parentheses following the FROM clause. (Again, the difference would have been more pronounced if there had been an elaborate WHERE clause.)

var
FetchCount: Word;
QueryAddress: TQuery;
{  ... }
QueryAddress := TQuery.Create(Self);
with QueryAddress do
begin
DatabaseName := 'CMIS_DB';
SQL.Add('SELECT AddressType, Address, City, County,   ');
SQL.Add('       State, ZipCode, ZipPlus4, PhoneNumber');
SQL.Add('  FROM SPS_Address_ProviderID (:ProviderID) ');
ParamByName('ProviderID').AsInteger :=
SubjectUpdateProviderID;
Open;

FetchCount := 0;
while EOF = False do
begin
with StringGridAddress do
begin
RowCount := FetchCount + 1;
Cells[0, FetchCount] := Fields[0].Text;
Cells[1, FetchCount] := Fields[1].Text;
Cells[2, FetchCount] := Fields[2].Text;
Cells[3, FetchCount] := Fields[3].Text;
Cells[4, FetchCount] := Fields[4].Text;
Cells[5, FetchCount] := Fields[5].Text;
Cells[6, FetchCount] := Fields[6].Text;
Cells[7, FetchCount] := Fields[7].Text;
end;
Inc(FetchCount);
Next;
end;

Free;

end;
Figure 8: Executing an InterBase select procedure from Object Pascal.

The rest of the procedure is the same: Multiple rows are being loaded into a StringGrid, with the Next method being used to fetch the next record in the answer stream. Note also that a looping structure would be unnecessary if the code were calling a singleton select.

Calling a Stored Procedure to Perform an INSERT, UPDATE, or DELETE Operation

As mentioned earlier, a Delphi StoredProc object must be used for SQL operations that do not return an answer set, i.e. the result of a SELECT statement. Therefore, they're used to call stored procedures that contain INSERT, UPDATE, and DELETE statements.

From a Delphi standpoint, these three statements are handled the same, so we'll look at just one - an UPDATE. The Object Pascal code in Figure 9 calls a stored procedure that contains the UPDATE statement from Figure 5.

var
StoredProcPenalty: TStoredProc;
{...}
StoredProcPenalty := TStoredProc.Create(Self);
with StoredProcPenalty do
begin
DatabaseName := 'cmis_db';
StoredProcName := 'SPU_Penalty';
Prepare;
ParamByName('PenaltyID').AsInteger := PenaltyPenaltyID;
ParamByName('PartyID').AsInteger := PenaltyPartyID;
ParamByName('PenaltyType').AsString :=
ComboBoxPenaltyType.Text;
ParamByName('PenaltyUnitType').AsString :=
ComboBoxPenaltyUnits.Text;
ParamByName('DateOfPenalty').AsDate :=
StrToDate(MaskEditPenaltyDate.Text);
ParamByName('PenaltyUnits').AsInteger :=
StrToInt(MaskEditPenalty.Text);
ExecProc;
Free;
end;
Figure 9: Executing a stored procedure that contains an INSERT statement.

There are some similarities: A StoredProc object is instantiated in the same way as a Query object, and its Database property must also be assigned.

After that, however, the similarities disappear. The StoredProcName property must be assigned the name of the stored procedure - in this case, SPU_Penalty. Also, the Prepare method must be used to tell the server to get the stored procedure ready to accept input, and otherwise prepare for execution. Note also that the ExecProc method is used instead of Open (just as it is when TQuery objects return no value).

After Prepare has been called, the parameters can be assigned just as they are with Query objects - using the ParamByName method. Finally, the ExecProc method is used to execute the stored procedure (again, in lieu of the Query Open method, because no value is returned).

Conclusion

We've examined real-world examples of how to use InterBase stored procedures to develop a client/server application with Delphi. Along the way, we've covered the basics of InterBase trigger and procedure language, and - among other things - learned how to build select procedures, and how to call stored procedures from Delphi.

Another benefit of learning InterBase trigger and procedure language is that it's very much like the procedural languages used by other database vendors (Oracle's PL/SQL, for example), so once you've mastered the InterBase flavor, you'll make short work of the next.

How to create a database at run-time with ZEOS

Problem/Question/Abstract:

How can I create a database at run-time with ZEOS?

Answer:

// Torry's Delphi Tips
// Author Rolf Warnecke
// Listed 29.03.2003

{
This unit creates a database on a Interbase-Server at run-time.
The IBConsole is no longer needed.
You can execute an SQL script to create tables.
Try it out!
}

{
Diese Unit erstellt eine Datenbank auf einem Interbase - Server zur Laufzeit des Programms.
Es wird nicht mehr die IBConsole gebraucht.
Dazu kann man im Memo noch ein SQL - Skript ablaufen lassen zum erstellen der Tabellen.
Probiert es einfach aus.
}

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ZTransact, ZIbSqlTr, DB, ZQuery, ZIbSqlQuery,
ZConnect, ZIbSqlCon;

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
ZIbSqlQuery1: TZIbSqlQuery;
ZIbSqlTransact1: TZIbSqlTransact;
ZIbSqlDatabase1: TZIbSqlDatabase;
Button3: TButton;
procedure Button1Click(Sender: TObject);
// Caption/ Beschriftung : Create Database
procedure Button2Click(Sender: TObject); // Caption/ Beschriftung : SQL-Anweisung
procedure Button3Click(Sender: TObject); // Caption/ Beschriftung : Drop Database
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

// Creating the database
// Hier wird durch dr�cken des Buttons die Datenbank erstellt
//---------------------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
begin
ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
ZIbSqlDatabase1.Host := 'testserver';
ZIbSqlDatabase1.Password := 'masterkey';
ZIbSqlDatabase1.Login := 'SYSDBA';
ZIbSqlDatabase1.CreateDatabase('');
end;

// Execute the SQL-Script in the memo
// Hier wird durch dr�cken des Buttons das SQL-Skript im Memo ausgef�hrt
//----------------------------------------------------------------------

procedure TForm1.Button2Click(Sender: TObject);
begin
ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
ZIbSqlDatabase1.Host := 'testserver';
ZIbSqlDatabase1.Password := 'masterkey';
ZIbSqlDatabase1.Login := 'SYSDBA';
ZIbSqlQuery1.SQL.Clear;
ZIbSqlQuery1.SQL.AddStrings(memo1.Lines);
ZIbSqlQuery1.ExecSQL;
end;

// Deleted the database
// Hier wird durch dr�cken des Buttons die Datenbank komplette gel�scht
//---------------------------------------------------------------------

procedure TForm1.Button3Click(Sender: TObject);
begin
ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
ZIbSqlDatabase1.Host := 'testserver';
ZIbSqlDatabase1.Password := 'masterkey';
ZIbSqlDatabase1.Login := 'SYSDBA';
ZIbSqlDatabase1.DropDatabase;
end;

end.

Converting a Bitmap to RTF code

Problem/Question/Abstract:

How do I convert a Bitmap to RTF code?

Answer:

function BitmapToRTF(pict: TBitmap): string;
var
bi, bb, rtf: string;
bis, bbs: Cardinal;
achar: ShortString;
hexpict: string;
I: Integer;
begin
GetDIBSizes(pict.Handle, bis, bbs);
SetLength(bi, bis);
SetLength(bb, bbs);
GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
rtf := '{\rtf1 {\pict\dibitmap0 ';
SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
I := 2;
for bis := 1 to Length(bi) do
begin
achar := IntToHex(Integer(bi[bis]), 2);
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
for bbs := 1 to Length(bb) do
begin
achar := IntToHex(Integer(bb[bbs]), 2);
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
rtf := rtf + hexpict + ' }}';
Result := rtf;
end;

Join two TMetaFile

Problem/Question/Abstract:

I wish to join two *.wmf files together - adding one to the end of the other.

Answer:

{ ... }
MetaFile1 := TMetaFile.Create;
MetaFile2 := TMetaFile.Create;
DestMetaFile := TMetaFile.Create;
try
MetaFile1.LoadFromFile('A0000259.WMF');
MetaFile2.LoadFromFile('A0000260.WMF');
DestMetaFile.Width := Max(MetaFile1.Width, MetaFile2.Width);
DestMetaFile.Height := MetaFile1.Height + MetaFile2.Height;
MetaFileCanvas := TMetaFileCanvas.Create(DestMetaFile, 0);
try
MetaFileCanvas.Draw(0, 0, MetaFile1);
MetaFileCanvas.Draw(0, MetaFile1.Height, MetaFile2);
finally
MetaFileCanvas.Free;
end;
DestMetaFile.SaveToFile('new.wmf');
finally
MetaFile1.Free;
MetaFile2.Free;
DestMetaFile.Free;
end;
{ ... }

VCL MS Word Spell Check and Thesaurus

Problem/Question/Abstract:

VCL MS Word Spell Check and Thesaurus

Answer:

This is the VCL for Spell Checking and Synonyms using MS Word COM interface. It can correct and replace words in a Text String,TMemo or TRichEdit using a built in replacement editor, or can be controlled by user dialog. I see there are other callable functions in the interface, which I have not implemented. Anyone see a use for any of them ?.

They are ...
  
    property PartOfSpeechList: OleVariant  read Get_PartOfSpeechList;
    property AntonymList: OleVariant read Get_AntonymList;
    property RelatedExpressionList: OleVariant  read Get_RelatedExpressionList;
    property RelatedWordList: OleVariant  read Get_RelatedWordList;

Example of checking and changing a Memo text ...

    SpellCheck.CheckMemoTextSpelling(Memo1);

Properties
----------------
LetterChars            - Characters considered to be letters. default is  
                                   ['A'..'Z','a'..'z'] (English) but could be changed to
                                   ['A'..'Z','a'..'z','�','�','�','�','�'] (Spanish)

Color                       - Backgound color of Default dialog Editbox and Listbox

CompletedMessage - Enable/Disable display of completed and count message dialog

Font                         - Font of Default dialog Editbox and Listbox

Language                - Language used by GetSynonyms() method

ReplaceDialog         - Use Default replace dialog or User defined  (see events)

Active                      - Readonly, set at create time. Indicates if MS Word is  available

Methods
----------------
function GetSynonyms(StrWord : string; Synonyms : TStrings) : boolean;

         True if synonyms found for StrWord. Synonyms List is  
         returned in TStrings (Synonyms).

function CheckWordSpelling(StrWord : string; Suggestions : TStrings) : boolean;

         True if StrWord is spelt correctly. Suggested corrections
         returned in TStrings (Suggestions)

procedure CheckTextSpelling(var StrText : string);

          Proccesses string StrText and allows users to change  
          mispelt  words via a Default replacement dialog or User  
          defined calls. Words are changed and returned in StrText.
          Words in the text are changed automatically by the Default
          editor. Use the  events if you want to control the dialog
          yourself. ie. Get the mispelt word, give a choice of
          sugesstions (BeforeCorrection), Change the word to
          corrected  (OnCorrection) and possibly display "Was/Now"
          (AfterCorrection)

procedure CheckRichTextSpelling(RichEdit : TRichEdit);

         Corrects misspelt words directly in TRichEdit.Text.
         Rich Format is maintained.

procedure CheckMemoTextSpelling(Memo : TMemo);

         Corrects misspelt words directly into a TMemo.Text.


Events (Mainly used when ReplaceDialog = repUser)
--------------------------------------------------------------------------------
BeforeCorrection - Supplies the mispelt word along with a TStrings
                                 var containing suggested corrections.

OnCorrection       - Supplies the mispelt word as a VAR type allowing
                                user to change it to desired word. The word will be
                                replaced by this variable in the passed StrText.

AfterCorrection  - Supplies the mispelt word and what it has been
                               changed to.


unit SpellChk;
interface

// =============================================================================
// MS Word COM Interface to Spell Check and Synonyms
// Mike Heydon Dec 2000
// mheydon@pgbison.co.za
// =============================================================================

uses Windows, SysUtils, Classes, ComObj, Dialogs, Forms, StdCtrls,
  Controls, Buttons, Graphics, ComCtrls, Variants;

// Above uses Variants is for Delphi 6 - remove for Delphi 5 and less

type
  // Event definitions
  TSpellCheckBeforeCorrection = procedure(Sender: TObject;
    MispeltWord: string;
    Suggestions: TStrings) of object;

  TSpellCheckAfterCorrection = procedure(Sender: TObject;
    MispeltWord: string;
    CorrectedWord: string) of object;

  TSpellCheckOnCorrection = procedure(Sender: TObject;
    var WordToCorrect: string) of object;

  // Property types
  TSpellCheckReplacement = (repDefault, repUser);
  TSpellCheckLetters = set of char;

  TSpellCheckLanguage = (wdLanguageNone, wdNoProofing, wdDanish, wdGerman,
    wdSwissGerman, wdEnglishAUS, wdEnglishUK, wdEnglishUS,
    wdEnglishCanadian, wdEnglishNewZealand,
    wdEnglishSouthAfrica, wdSpanish, wdFrench,
    wdFrenchCanadian, wdItalian, wdDutch, wdNorwegianBokmol,
    wdNorwegianNynorsk, wdBrazilianPortuguese,
    wdPortuguese, wdFinnish, wdSwedish, wdCatalan, wdGreek,
    wdTurkish, wdRussian, wdCzech, wdHungarian, wdPolish,
    wdSlovenian, wdBasque, wdMalaysian, wdJapanese, wdKorean,
    wdSimplifiedChinese, wdTraditionalChinese,
    wdSwissFrench, wdSesotho, wdTsonga, wdTswana, wdVenda,
    wdXhosa, wdZulu, wdAfrikaans, wdArabic, wdHebrew,
    wdSlovak, wdFarsi, wdRomanian, wdCroatian, wdUkrainian,
    wdByelorussian, wdEstonian, wdLatvian, wdMacedonian,
    wdSerbianLatin, wdSerbianCyrillic, wdIcelandic,
    wdBelgianFrench, wdBelgianDutch, wdBulgarian,
    wdMexicanSpanish, wdSpanishModernSort, wdSwissItalian);

  // Main TSpellcheck Class
  TSpellCheck = class(TComponent)
  private
    MsWordApp,
      MsSuggestions: OleVariant;
    FLetterChars: TSpellCheckLetters;
    FFont: TFont;
    FColor: TColor;
    FReplaceDialog: TSpellCheckReplacement;
    FCompletedMessage,
      FActive: boolean;
    FLanguage: TSpellCheckLanguage;
    FForm: TForm;
    FEbox: TEdit;
    FLbox: TListBox;
    FCancelBtn,
      FChangeBtn: TBitBtn;
    FBeforeCorrection: TSpellCheckBeforeCorrection;
    FAfterCorrection: TSpellCheckAfterCorrection;
    FOnCorrection: TSpellCheckOnCorrection;
    procedure SetFFont(NewValue: TFont);
  protected
    procedure MakeForm;
    procedure CloseForm;
    procedure SuggestedClick(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetSynonyms(StrWord: string; Synonyms: TStrings): boolean;
    function CheckWordSpelling(StrWord: string;
      Suggestions: TStrings): boolean;
    procedure CheckTextSpelling(var StrText: string);
    procedure CheckRichTextSpelling(RichEdit: TRichEdit);
    procedure CheckMemoTextSpelling(Memo: TMemo);
    procedure Anagrams(const InString: string; StringList: TStrings);
    property Active: boolean read FActive;
    property LetterChars: TSpellCheckletters read FLetterChars write FLetterChars;
  published
    property Language: TSpellCheckLanguage read FLanguage
      write FLanguage;
    property CompletedMessage: boolean read FCompletedMessage
      write FCompletedMessage;
    property Color: TColor read FColor write FColor;
    property Font: TFont read FFont write SetFFont;
    property BeforeCorrection: TSpellCheckBeforeCorrection
      read FBeforeCorrection
      write FBeforeCorrection;
    property AfterCorrection: TSpellCheckAfterCorrection
      read FAfterCorrection
      write FAfterCorrection;
    property OnCorrection: TSpellCheckOnCorrection
      read FOnCorrection
      write FOnCorrection;
    property ReplaceDialog: TSpellCheckReplacement
      read FReplaceDialog
      write FReplaceDialog;
  end;

procedure Register;

// -----------------------------------------------------------------------------
implementation

// Mapped Hex values for ord(FLanguage)
const

  LanguageArray: array[0..63] of integer =
  ($0, $400, $406, $407, $807, $C09, $809, $409,
    $1009, $1409, $1C09, $40A, $40C, $C0C, $410,
    $413, $414, $814, $416, $816, $40B, $41D, $403,
    $408, $41F, $419, $405, $40E, $415, $424, $42D,
    $43E, $411, $412, $804, $404, $100C, $430, $431,
    $432, $433, $434, $435, $436, $401, $40D, $41B,
    $429, $418, $41A, $422, $423, $425, $426, $42F,
    $81A, $C1A, $40F, $80C, $813, $402, $80A, $C0A, $810);

  // Change to Component Pallete of choice

procedure Register;
begin
  RegisterComponents('MahExtra', [TSpellCheck]);
end;

// TSpellCheck

constructor TSpellCheck.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // Defaults
  FLetterChars := ['A'..'Z', 'a'..'z'];
  FCompletedMessage := true;
  FColor := clWindow;
  FFont := TFont.Create;
  FReplaceDialog := repDefault;
  FLanguage := wdEnglishUS;

  // Don't create an ole server at design time
  if not (csDesigning in ComponentState) then
  begin
    try
      MsWordApp := CreateOleObject('Word.Application');
      FActive := true;
      MsWordApp.Documents.Add;
    except
      on E: Exception do
      begin
        // MessageDlg('Cannot Connect to MS Word',mtError,[mbOk],0);
        // Activate above if visual failure required
        FActive := false;
      end;
    end;
  end;
end;

destructor TSpellCheck.Destroy;
begin
  FFont.Free;

  if FActive and not (csDesigning in ComponentState) then
  begin
    MsWordApp.Quit;
    MsWordApp := VarNull;
  end;

  inherited Destroy;
end;

// ======================================
// Property Get/Set methods
// ======================================

procedure TSpellCheck.SetFFont(NewValue: TFont);
begin
  FFont.Assign(NewValue);
end;

// ===========================================
// Return a list of synonyms for single word
// ===========================================

function TSpellCheck.GetSynonyms(StrWord: string;
  Synonyms: TStrings): boolean;
var
  SynInfo: OleVariant;
  i, j: integer;
  TS: OleVariant;
  Retvar: boolean;
begin
  Synonyms.Clear;

  if FActive then
  begin
    SynInfo := MsWordApp.SynonymInfo[StrWord,
      LanguageArray[ord(FLanguage)]];
    for i := 1 to SynInfo.MeaningCount do
    begin
      TS := SynInfo.SynonymList[i];
      for j := VarArrayLowBound(TS, 1) to VarArrayHighBound(TS, 1) do
        Synonyms.Add(TS[j]);
    end;

    RetVar := SynInfo.Found;
  end
  else
    RetVar := false;

  Result := RetVar;
end;

// =======================================
// Check the spelling of a single word
// Suggestions returned in TStrings
// =======================================

function TSpellCheck.CheckWordSpelling(StrWord: string;
  Suggestions: TStrings): boolean;
var
  Retvar: boolean;
  i: integer;
begin
  RetVar := false;
  if Suggestions <> nil then
    Suggestions.Clear;

  if FActive then
  begin
    if MsWordApp.CheckSpelling(StrWord) then
      RetVar := true
    else
    begin
      if Suggestions <> nil then
      begin
        MsSuggestions := MsWordApp.GetSpellingSuggestions(StrWord);
        for i := 1 to MsSuggestions.Count do
          Suggestions.Add(MsSuggestions.Item(i));
        MsSuggestions := VarNull;
      end;
    end;
  end;

  Result := RetVar;
end;

// ======================================================
// Check the spelling text of a string with option to
// Replace words. Correct string returned in var StrText
// ======================================================

procedure TSpellCheck.CheckTextSpelling(var StrText: string);
var
  StartPos, CurPos,
    WordsChanged: integer;
  ChkWord, UserWord: string;
  EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (StartPos <= length(StrText)) and
      (not (StrText[StartPos] in FLetterChars)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    CloseForm;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// =============================================================
// Check the spelling of RichText with option to
// Replace words (in situ replacement direct to RichEdit.Text)
// =============================================================

procedure TSpellCheck.CheckRichTextSpelling(RichEdit: TRichEdit);
var
  StartPos, CurPos,
    WordsChanged: integer;
  StrText, ChkWord, UserWord: string;
  SaveHide,
    EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (not (StrText[StartPos] in FLetterChars)) and
      (StartPos <= length(StrText)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  SaveHide := RichEdit.HideSelection;
  RichEdit.HideSelection := false;
  StrText := RichEdit.Text;
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            RichEdit.SelStart := StartPos - 1;
            RichEdit.SelLength := length(ChkWord);
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);
              RichEdit.SelText := FEbox.Text;

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            RichEdit.SelStart := StartPos - 1;
            RichEdit.SelLength := length(ChkWord);
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);
            RichEdit.SelText := UserWord;

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    CloseForm;
    RichEdit.HideSelection := SaveHide;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// =============================================================
// Check the spelling of Memo with option to
// Replace words (in situ replacement direct to Memo.Text)
// =============================================================

procedure TSpellCheck.CheckMemoTextSpelling(Memo: TMemo);
var
  StartPos, CurPos,
    WordsChanged: integer;
  StrText, ChkWord, UserWord: string;
  SaveHide,
    EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (not (StrText[StartPos] in FLetterChars)) and
      (StartPos <= length(StrText)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  SaveHide := Memo.HideSelection;
  Memo.HideSelection := false;
  StrText := Memo.Text;
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            Memo.SelStart := StartPos - 1;
            Memo.SelLength := length(ChkWord);
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);
              Memo.SelText := FEbox.Text;

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            Memo.SelStart := StartPos - 1;
            Memo.SelLength := length(ChkWord);
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);
            Memo.SelText := UserWord;

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    Memo.HideSelection := SaveHide;
    CloseForm;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// ======================================================================
// Return a list of Anagrams - Careful, long words generate HUGE lists
// ======================================================================

procedure TSpellCheck.Anagrams(const InString: string; StringList: TStrings);
var
  WordsChecked, WordsFound: integer;

  procedure RecursePerm(const StrA, StrB: string; Len: integer; SL: TStrings);
  var
    i: integer;
    A, B: string;
  begin
    if (length(StrA) = Len) then
    begin
      inc(WordsChecked);
      if (SL.IndexOf(StrA) = -1) and MsWordApp.CheckSpelling(StrA) then
      begin
        inc(WordsFound);
        SL.Add(StrA);
        Application.ProcessMessages;
      end;
    end;

    for i := 1 to length(StrB) do
    begin
      A := StrB;
      B := StrA + A[i];
      delete(A, i, 1);
      RecursePerm(B, A, Len, SL);
    end;
  end;

begin
  if FActive then
  begin
    WordsChecked := 0;
    WordsFound := 0;
    StringList.Clear;
    Application.ProcessMessages;
    RecursePerm('', LowerCase(InString), length(InString), StringList);
    if FCompletedMessage then
      MessageDlg('Anagram Search Check Complete' + #13#10 +
        IntToStr(WordsChecked) + ' words checked' + #13#10 +
        IntToStr(WordsFound) + ' anagrams found',
        mtInformation, [mbOk], 0);
  end
  else
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0);
end;

// =========================================
// Create default replacement form
// =========================================

procedure TSpellCheck.MakeForm;
begin
  // Correction form container
  FForm := TForm.Create(nil);
  FForm.Position := poScreenCenter;
  FForm.BorderStyle := bsDialog;
  FForm.Height := 260; // 240 if no caption
  FForm.Width := 210;

  // Remove form's caption if desired
  //  SetWindowLong(FForm.Handle,GWL_STYLE,
  //                GetWindowLong(FForm.Handle,GWL_STYLE) AND NOT WS_CAPTION);

  FForm.ClientHeight := FForm.Height;

  // Edit box of offending word
  FEbox := TEdit.Create(FForm);
  FEbox.Parent := FForm;
  FEbox.Top := 8;
  FEbox.Left := 8;
  FEbox.Width := 185;
  FEBox.Font := FFont;
  FEbox.Color := FColor;

  // Suggestion list box
  FLbox := TListBox.Create(FForm);
  FLbox.Parent := FForm;
  FLbox.Top := 32;
  FLbox.Left := 8;
  FLbox.Width := 185;
  FLbox.Height := 193;
  FLbox.Color := FColor;
  FLbox.Font := FFont;
  FLbox.OnClick := SuggestedClick;
  FLbox.OnDblClick := SuggestedClick;

  // Cancel Button
  FCancelBtn := TBitBtn.Create(FForm);
  FCancelBtn.Parent := FForm;
  FCancelBtn.Top := 232;
  FCancelBtn.Left := 8;
  FCancelBtn.Kind := bkCancel;
  FCancelBtn.Caption := 'Ignore';

  // Change Button
  FChangeBtn := TBitBtn.Create(FForm);
  FChangeBtn.Parent := FForm;
  FChangeBtn.Top := 232;
  FChangeBtn.Left := 120;
  FChangeBtn.Kind := bkOk;
  FChangeBtn.Caption := 'Change';
end;

// =============================================
// Close the correction form and free memory
// =============================================

procedure TSpellCheck.CloseForm;
begin
  FChangeBtn.Free;
  FCancelBtn.Free;
  FLbox.Free;
  FEbox.Free;
  FForm.Free;
end;

// ====================================================
// FLbox on click event to populate the edit box
// with selected suggestion (OnClick/OnDblClick)
// ====================================================

procedure TSpellCheck.SuggestedClick(Sender: TObject);
begin
  FEbox.Text := FLbox.Items[FLbox.ItemIndex];
end;

end.

Using One Event for many Components

Problem/Question/Abstract:

Using One Event for many Components

Answer:

This tip is a pretty basic one, but if you haven't come across it, using it can make your coding a lot easier and more efficient.

Delphi allows one coded event to be assigned to many event handlers as long as the methods are of the same type - ie., they have the same arguments.  The classic example is the OnClick event which is shared by many components.  This can be done in code in the following way.

procedure ClickMyComponent(Sender: Tobject);
begin
  //Some code goes here
  ShowMessage('This is my Onclick handler');
end;

{You can then assign this procedure to as many event handlers as you wish.}

procedure AssignEvents;
begin
  MyButton.OnClick := ClickMyComponent;
  MyLabel.OnClick := ClickMyComponent;
  MyCombo.Onclick := ClickMyComponent;
  // You Get the message!
end;

Each time one of these components is clicked, the above procedure 'ClickMyComponent' is executed.  This can be useful is certain circumstances, but mainly in this tip it serves to illustrate my main point  - reduce designtime coding by assigning events.

Assigning at designtime.

In the object inspector you may have noticed that the right hand side of the events tab is a combo box.  This allows you to choose to assign an already written event handler to the current components event (only event handlers of the right type are shown in the combo box).  This is the design time way of doing the above code.

At a glance it can seem like a nice but essentially useless ability to have.  How often are you likely to have two buttons, or a button and a label that share the same onclick code.  This may be true but it does happen.  Also an area where you do have many controls sharing code is in respect to Main Menus, Popup Menus and Speedbuttons.

eg.,

You want to let the user of your application be able to set the view type of a TlistView component at run time so you assign the four values to a View Menu  on your main menu and you right the necessary code in each event handler of each menu item.  Later on you decide to add speedbuttons, and a popupmenu in the listview to do the same thing.

Do you rewrite all the code?  Redo all the work you have done (even if you cut and paste)?

No you assign each new speedbutton and popupmenu item in its onclick handler in the objectInspector the handler for the corresponding mainmenu item.

Voila, you've managed to save yourself a lot of hassle and time and made your code more efficient (although possibly slightly harder to follow - so comment well).

Hope this is of use.

Read any MAPI complient emails

Problem/Question/Abstract:

How can read emails from OutlookExpress, Outlook or Eudora from a Delphi program?

Answer:

We can read emails from any MAPI compliant email client using MAPI. The bad news is that we cannot read formatted email using simple MAPI, but only the plain text and attachments.

That�s because MAPI was created before HTML formatted emails were created. But MAPI can bevery useful anyway.

To run this program create a blank form (on IDE point to "File/Close all", then "File/New Application"), put a button on it, a Label (both on standard tab)and a RichEdit (on Win32 tab; I used a RichEdit because Memo can  only handle 32k of text).

unit Unit1;

{*****************************************************************
*       Simple MAPI sample                                      *
*       Source written by Rafael Cotta (rcotta.geo@yahoo.com)   *
*       July 26th, 2001                                         *
*****************************************************************}

// To run this sample, place on a blank form a TRichEdit, a TLabel
// and a TButton

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, MAPI;

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  hndMAPISession: Cardinal;
  v_CurrentMsgID: array[0..512] of char; // I�ll use long IDs here
implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Initializing components and variables
  v_CurrentMsgID[0] := #0;

  hndMAPISession := 0;

  Button1.Caption := 'Read Next';
  RichEdit1.Lines.Clear;
  Label1.Caption := 'Subject : ';

end;

procedure TForm1.Button1Click(Sender: TObject);
var
  dwRet: Cardinal;
  v_Out: array[0..512] of char;
  oMsg: PMapiMessage;
begin
  Label1.Caption := 'Retrieving... wait';

  if hndMAPISession = 0 then
  begin
    dwRet := MapiLogOn(
      Handle, // This window�s handle
      '', // If you want to use another profile that�s
      '', // not the default, set these two parameters
      MAPI_LOGON_UI, // Will prompt for logon if necessary
      0, // Reserve, must be 0
      @hndMAPISession);

    // An error occurred
    if (dwRet <> SUCCESS_SUCCESS) then
    begin
      MessageBox(Handle, PChar('Error ' + IntToHex(dwRet, 8) +
        ' while trying to logon'), PChar('Error'),
        MB_OK + MB_ICONERROR);
      Application.Terminate;
      Exit;
    end;
  end;

  dwRet := MapiFindNext(
    hndMAPISession,
    Handle,
    nil, // All messages
    @v_CurrentMsgID,
    MAPI_GUARANTEE_FIFO {sort by date; you can use "or MAPI_UNREAD_ONLY"},
    0,
    @v_Out // The messageId of message next to v_Current will be here
    );

  // Reached the end, so, going to first message
  if dwRet = MAPI_E_NO_MESSAGES then
  begin
    v_CurrentMsgID[0] := #0;

    MessageBox(Handle,
      PChar('Last message reached. Going to first one in InBox'),
      PChar('MAPI sample'),
      MB_OK + MB_ICONEXCLAMATION);

    dwRet := MapiFindNext(
      hndMAPISession,
      Handle,
      nil, // All messages
      @v_CurrentMsgID,
      MAPI_GUARANTEE_FIFO {sort by date; you can use "or MAPI_UNREAD_ONLY"},
      0,
      @v_Out // The messageId of message next to v_Current will be here
      );
  end;

  StrCopy(@v_CurrentMsgID, @v_Out);
  dwRet := MapiReadMail(
    hndMAPISession,
    Handle,
    @v_CurrentMsgID,
    MAPI_PEEK, // Won�t mark message as read
    0,
    oMsg
    );

  if dwRet = SUCCESS_SUCCESS then
  begin
    RichEdit1.SetTextBuf(oMsg.lpszNoteText);
    Label1.Caption := 'Subject : ' + StrPas(oMsg.lpszSubject);
  end;

  if Assigned(oMsg) then
    MapiFreeBuffer(oMsg);

end;

end.

Rotate the text in a StringGrid cell by 90�

Problem/Question/Abstract:

How to rotate the text in a StringGrid cell by 90�

Answer:

Solve 1:

uses
  {...} Grids;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  end;

  {...}

implementation

{...}

// Display text vertically in StringGrid cells

procedure StringGridRotateTextOut(Grid: TStringGrid; ARow, ACol: Integer; Rect: TRect;
  Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);
var
  lf: TLogFont;
  tf: TFont;
begin
  // if the font is to big, resize it
  if (Size > Grid.ColWidths[ACol] div 2) then
    Size := Grid.ColWidths[ACol] div 2;
  with Grid.Canvas do
  begin
    // Replace the font
    Font.Name := Schriftart;
    Font.Size := Size;
    Font.Color := Color;
    tf := TFont.Create;
    try
      tf.Assign(Font);
      GetObject(tf.Handle, SizeOf(lf), @lf);
      lf.lfEscapement := 900;
      lf.lfOrientation := 0;
      tf.Handle := CreateFontIndirect(lf);
      Font.Assign(tf);
    finally
      tf.Free;
    end;
    // fill the rectangle
    FillRect(Rect);
    // Align text and write it
    if Alignment = taLeftJustify then
      TextRect(Rect, Rect.Left + 2, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taCenter then
      TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size +
        Size div 3, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taRightJustify then
      TextRect(Rect, Rect.Right - Size - Size div 2 - 2, Rect.Bottom -
        2, Grid.Cells[ACol, ARow]);
  end;
end;


Solve 2:

Display text vertically in StringGrid cells

procedure StringGridRotateTextOut2(Grid: TStringGrid; ARow, ACol: Integer; Rect:
  TRect;
  Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);
var
  NewFont, OldFont: Integer;
  FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;
begin
  // if the font is to big, resize it
  if (Size > Grid.ColWidths[ACol] div 2) then
    Size := Grid.ColWidths[ACol] div 2;
  with Grid.Canvas do
  begin
    // Set font
    if (fsBold in Font.Style) then
      FontStyle := FW_BOLD
    else
      FontStyle := FW_NORMAL;

    if (fsItalic in Font.Style) then
      FontItalic := 1
    else
      FontItalic := 0;

    if (fsUnderline in Font.Style) then
      FontUnderline := 1
    else
      FontUnderline := 0;

    if (fsStrikeOut in Font.Style) then
      FontStrikeout := 1
    else
      FontStrikeout := 0;

    Font.Color := Color;

    NewFont := CreateFont(Size, 0, 900, 0, FontStyle, FontItalic,
      FontUnderline, FontStrikeout, DEFAULT_CHARSET,
      OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
      DEFAULT_PITCH, PChar(Schriftart));

    OldFont := SelectObject(Handle, NewFont);
    // fill the rectangle
    FillRect(Rect);
    // Write text depending on the alignment
    if Alignment = taLeftJustify then
      TextRect(Rect, Rect.Left + 2, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taCenter then
      TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size + Size div 3,
        Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taRightJustify then
      TextRect(Rect, Rect.Right - Size - Size div 2 - 2, Rect.Bottom - 2,
        Grid.Cells[ACol, ARow]);

    // Recreate reference to the old font
    SelectObject(Handle, OldFont);
    // Recreate reference to the new font
    DeleteObject(NewFont);
  end;
end;

// Call the method in OnDrawCell

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol,
  ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
  // In the second column: Rotate Text by 90� and left align the text
  if ACol = 1 then
    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL',
      12, clRed, taLeftJustify);

  // In the third column: Center the text
  if ACol = 2 then
    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clBlue,
      taCenter);

  // In all other columns third row: right align the text
  if ACol > 2 then
    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clGreen,
      taRightJustify);
end;

end.

Creating "Dynamic" Arrays

Problem/Question/Abstract:

Is it possible to re-size arrays at runtime?

Answer:

I came across an example of how to do one. The author is Ben Licht, who presents an age-old Pascal method of creating a dynamic array.

The trick is using a pointer to an array with a size of 1, then allocating memory for the pointer by multiplying the number of items you want in the array by the size of the array type.

Here's a sample unit I've adapted from his example:

{This unit demonstrates how to implement a dynArray}
unit U;

interface

uses
  SysUtils, WinTypes, WinProcs, Classes, Controls, Forms, Dialogs, StdCtrls;

type
  TResizeArr = array[0..0] of string;
  PResizeArr = ^TResizeArr;
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

procedure DefineDynArray(var h: THandle; {Handle to mem pointer}
  NumElements: LongInt; {Number of items in array}
  var PArr: PResizeArr); {Pointer to array struct}

procedure TestDynArray;

implementation
{$R *.DFM}

{============================================================================
Procedure that defines the dynarray. Note that the THandle and Pointer to
the array are passed by reference. This enables them to be defined outside
the scope of this procedure.
============================================================================}

procedure DefineDynArray(var h: THandle; {Handle to mem pointer}
  NumElements: LongInt; {Number of items in array}
  var PArr: PResizeArr); {Pointer to array struct}
begin

  {Allocate Windows Global Heap memory}
  h := GlobalAlloc(GMEM_FIXED, NumElements * sizeof(TResizeArr));
  PArr := GlobalLock(h);
end;

{============================================================================
Procedure that uses the DefineDynArray proc. This is pretty useless, but
provides a good example of how you can access the elements of the 'array'
once the array is defined.
============================================================================}

procedure TestDynArray;
var
  MyArray: PResizeArr;
  I: Integer;
  str: string;
  h: THandle;
begin
  str := '';
  DefineDynArray(h, 10, MyArray); {Define the 'array'}
  for I := 0 to 9 do
    MyArray^[I] := IntToStr(I);
  for I := 0 to 9 do
    str := str + MyArray^[I] + ',';
  ShowMessage(str);
  GlobalUnlock(h); {Must make a call to unlock the memory, then}
  GlobalFree(h); {free the memory and invalidate the handle}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  TestDynArray;
end;

end.

This is a perfect example of one of those programming things that take hours to figure out, but turn out to be amazingly simple. But I should point out that it might just be simpler to use a TList, which does all of the above, but has methods to insert and delete items. It's only limited by the amount of memory you have.

How to register an ActiveX library at runtime and create the corresponding ActiveX control

Problem/Question/Abstract:

I want to write a client application which, when it starts, scans a given directory for ActiveX Form OCX's. If found, I want each ActiveForm to be loaded into the interface. This forms a modular plug-in style interface. Can anyone give me some advice on how to (register?) invoke and create an ActiveForm given just an OCX.

Answer:

The steps are:

Runtime registration of the ActiveX library
Runtime creation of the ActiveX control
Invoking methods


1. Registration of the ActiveX library


The code can be found in the source code of the TRegSrv project (Delphi4\demos\activex\tregsrv). The crucial steps are listed below (this is a procedure that I'm using myself. Could be that you will have to look for the units to include).


type
  TRegProc = function: HResult; stdcall;

procedure RegisterActiveXControl(Name: string; Extension: string);
{name is the name of the ActiveX control, Extension is 'ocx' or 'dll'}
var
  LibHandle: THandle;
  FileName: TFileName;
  RegProc: TRegProc;
begin
  {don't mind the path, use your own filename of your own ActiveX control}
  FileName := 'C:\Temp\PAx' + Name + '.' + Extension;
  {this line gets a handle to the ActiveX library}
  LibHandle := LoadLibrary(PChar(FileName));
  {prepares the registration}
  @RegProc := GetProcAddress(LibHandle, 'DllRegisterServer');
  if (not (@RegProc = nil)) then
  begin
    {this line executes the registration procedure, if the file is a correct ActiveX library}
    RegProc;
  end;
  {afterwards, the handle to the file is destroyed}
  FreeLibrary(LibHandle);
end;


2. Runtime creation of the corresponding ActiveX control

You need the following, in a procedure, function or method:


var
  AxControl: OleVariant;
begin
  AxControl := CreateOleObject(AxName);
  {in which AxName is something like 'AxLibraryName.AxControlName' (cf. 'Word.Basic'). You can find this AxName in the ProgID section of the registry}
  Result := AxControl.Execute(a, b); {Execute is a method of the AxControl}
end;

Convert from UNC notation to Drive letter?

Problem/Question/Abstract:

Convert from UNC notation to Drive letter?

Answer:

The function ExpandUNCFileName function converts a mapped path/file to UNC, but how can this process be reversed?

There is no simple function that would do the trick, you have to go through all existing 'remote' drives, look at their UNC name and compare them with the one you are interested in:


program P;

procedure TForm1.Button1Click(Sender: TObject);
const
  YOURUNCFILENAME = '\\ISS\VOL1\ISS\SHARE\';
var
  Drive: Char;
  Drlist: TStringList;
  Filist: TStringList;
  I: integer;
begin
  Drlist := TStringList.Create;
  Filist := TStringList.Create;
  for Drive := 'a' to 'z' do
    case GetDriveType(PChar(Drive + ':\')) of
      DRIVE_REMOTE:
        begin
          Filist.Add(expanduncfilename(Drive + ':\'));
          Drlist.Add(Drive)
        end
    end;
  {......}
  I := Filist.indexof(YOURUNCFILENAME);
  if I > -1 then
    ShowMessage(YOURUNCFILENAME + 'Mapped to drive ' + Drlist[I]);

  Drlist.Free;
  Filist.Free
end;

end.

Filling the screen with your form

Problem/Question/Abstract:

I'd like to resize a form and have it fill up the screen. But I don't want it to display over the Win95/WinNT taskbar. Is there a way to do this?

Answer:

I put the code in a component wrapper so all you have to do is drop the component onto any form, call the component's execute procedure in FormCreate, and voila! an instantly sized form that fits nicely within your screen, above the Taskbar.

For Non-Windows 95 users, your form will be sized to maximized, but will be still be FormStyle := wsNormal. Select the text below, put it in a file, save the file as SizeTask.pas, add into your component library, drop it into a form, and watch it go!

unit Sizetask;

interface

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

type
  TSizer = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure SetSize(MyForm: TForm);
  public
    { Public declarations }
    procedure Execute;
  end;

procedure Register;

implementation

procedure TSizer.Execute;
begin
  SetSize(TForm(Owner));
end;

procedure TSizer.SetSize(MyForm: TForm);
var
  TaskBarHandle: HWnd; { Handle to the Win95 Taskbar }
  TaskBarCoord: TRect; { Coordinates of the Win95 Taskbar }
  CxScreen, { Width of screen in pixels }
  CyScreen, { Height of screen in pixels }
  CxFullScreen, { Width of client area in pixels }
  CyFullScreen, { Height of client area in pixels }
  CyCaption: Integer; { Height of a window's title bar in pixels }
begin
  TaskBarHandle := FindWindow('Shell_TrayWnd', nil); { Get Win95 Taskbar handle }
  if TaskBarHandle = 0 then { We're running Win 3.x or WinNT w/o Win95
    shell, so just maximize }
    MyForm.WindowState := wsMaximized
  else { We're running Win95 or WinNT w/Win95 shell }
  begin
    MyForm.WindowState := wsNormal;
    GetWindowRect(TaskBarHandle, TaskBarCoord); { Get coordinates of Win95 Taskbar }
    CxScreen := GetSystemMetrics(SM_CXSCREEN);
      { Get various screen dimensions and set form's width/height }
    CyScreen := GetSystemMetrics(SM_CYSCREEN);
    CxFullScreen := GetSystemMetrics(SM_CXFULLSCREEN);
    CyFullScreen := GetSystemMetrics(SM_CYFULLSCREEN);
    CyCaption := GetSystemMetrics(SM_CYCAPTION);
    MyForm.Width := CxScreen - (CxScreen - CxFullScreen) + 1;
    MyForm.Height := CyScreen - (CyScreen - CyFullScreen) + CyCaption + 1;
    MyForm.Top := 0;
    MyForm.Left := 0;
    if (TaskBarCoord.Top = -2) and (TaskBarCoord.Left = -2) then
      {Taskbar on either top or left }
      if TaskBarCoord.Right > TaskBarCoord.Bottom then { Taskbar on top }
        MyForm.Top := TaskBarCoord.Bottom
      else { Taskbar on left }
        MyForm.Left := TaskBarCoord.Right;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TSizer]);
end;

end.

How to create stereo wave files with accurate frequencies

Problem/Question/Abstract:

How do I generate low frequency audio < 1000 Hz with one frequency to the left channel and a slightly different frequency to the right? For example , a tone of 400 Hz is presented to the right ear and a tone of 410 Hz is presented simultaneously to the left ear ? I'm trying to write a small binaural beat test program. I understand the science but not how to generate the two tones in Windows.

Answer:

Assuming you want precise control over the waveforms, the best thing to do is to create a stereo .WAV file containing the desired data. Here's a function that will do that; you can adapt it to your needs (add MMSystem to your USES list):


procedure CreateSineWave(LeftFreq, RightFreq: Single; Duration: Cardinal; const FileName: string);
const
  BitsPerSample = 16;
  NumChannels = 2;
  SampleRate = 44100;
var
  ChunkSize: Integer;
  DataSize: Integer;
  Factor: Single;
  Format: TWaveFormatEx;
  FourCC: array[0..3] of Char;
  I: Integer;
  NumSamples: Integer;
  L: SmallInt;
  R: SmallInt;
  WaveStream: TFileStream;
begin
  WaveStream := TFileStream.Create(FileName, fmCreate);
  try
    FourCC := 'RIFF';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    NumSamples := (SampleRate * Duration) div 1000;
    DataSize := (BitsPerSample shr 3) * NumChannels * NumSamples;
    ChunkSize := DataSize + SizeOf(TWaveFormatEx) + 20;
    WaveStream.Write(ChunkSize, SizeOf(ChunkSize));
    FourCC := 'WAVE';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    FourCC := 'fmt ';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    ChunkSize := SizeOf(TWaveFormatEx);
    WaveStream.Write(ChunkSize, SizeOf(ChunkSize));
    with Format do
    begin
      wFormatTag := WAVE_FORMAT_PCM;
      nChannels := NumChannels;
      nSamplesPerSec := SampleRate;
      wBitsPerSample := BitsPerSample;
      nBlockAlign := nChannels * wBitsPerSample shr 3;
      nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
      cbSize := 0
    end;
    WaveStream.Write(Format, SizeOf(Format));
    FourCC := 'data';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    ChunkSize := DataSize;
    WaveStream.Write(ChunkSize, SizeOf(ChunkSize));
    for I := 0 to 999 do
    begin
      Factor := Exp(-0.005 * (1000 - I));
      L := Round(Factor * 32767 * Sin(2 * Pi * LeftFreq * I / SampleRate));
      R := Round(Factor * 32767 * Sin(2 * Pi * RightFreq * I / SampleRate));
      WaveStream.Write(L, SizeOf(L));
      WaveStream.Write(R, SizeOf(R))
    end;
    for I := 1000 to NumSamples - 1001 do
    begin
      L := Round(32767 * Sin(2 * Pi * LeftFreq * I / SampleRate));
      R := Round(32767 * Sin(2 * Pi * RightFreq * I / SampleRate));
      WaveStream.Write(L, SizeOf(L));
      WaveStream.Write(R, SizeOf(R))
    end;
    for I := NumSamples - 1000 to NumSamples - 1 do
    begin
      Factor := Exp(0.005 * (NumSamples - 1001 - I));
      L := Round(Factor * 32767 * Sin(2 * Pi * LeftFreq * I / SampleRate));
      R := Round(Factor * 32767 * Sin(2 * Pi * RightFreq * I / SampleRate));
      WaveStream.Write(L, SizeOf(L));
      WaveStream.Write(R, SizeOf(R))
    end;
    WaveStream.Position := 0;
  finally
    WaveStream.Free
  end
end;



So, for example, to create a two-second sample having a 400 Hz left channel and a 410 Hz right channel:


CreateSineWave(400.0, 410.0, 2000, 'foo.wav');


You can play the sound like this:


sndPlaySound('foo.wav', SND_SYNC);

Check which subitem of a TListView's ListItem was clicked (2)

Problem/Question/Abstract:

Is it possible to activate the click or double-click event for the subitems of a listview item? If yes, how can I do it?

Answer:

uses
  CommCtrl;

{$R *.dfm}

procedure TForm1.ListView1Click(Sender: TObject);
var
  pt: TPoint;
  item: TLIstItem;
  hittestinfo: TLVHitTestInfo;
begin
  pt := listview1.ScreenToClient(mouse.cursorpos);
  item := listview1.GetItemAt(pt.x, pt.y);
  if assigned(item) then
    memo1.Lines.add('Hit on item ' + item.Caption)
  else
  begin
    FillChar(hittestinfo, sizeof(hittestinfo), 0);
    hittestinfo.pt := pt;
    if - 1 <> listview1.perform(LVM_SUBITEMHITTEST, 0, lparam(@hittestinfo)) then
    begin
      memo1.lines.add(format('Item: %d (%s), subitem: %d (%s)', [hittestinfo.iItem,
        listview1.items[hittestinfo.iItem].caption, hittestinfo.iSubItem,
          listview1.items[hittestinfo.iItem].Subitems[hittestinfo.iSubItem - 1]]));

    end
    else
      memo1.lines.add('Not on item or subitem');
  end;
end;

Disabling an event handler once it has executed once

Problem/Question/Abstract:

Disabling an event handler once it has executed once

Answer:

Have you ever wanted to keep an event from firing once it has executed once? Simply set the event handler method to nil in the body of the method. For instance, let's say you want to disable an OnClick for a button once the user has pressed it. Here's the code to do that:

procedure Button1OnClick;
begin
  Button1.OnClick := nil;
end;

Prenventing the user from positioning a form outside the screen work area

Problem/Question/Abstract:

How can I prevent the user from moving the form outside screen boundaries to guarantee the form is always visible inside the screen work area?

Answer:

We can know if a form has resized with the Resize event (OnResize property), but how do we know if a form has moved? Simply by capturing the WM_MOVE Windows message.

In the message event we call "inherited" to let the ancestors of TForm process the message. This will update the Left and Top properties that we can use along with Width and Height to see if the form is placed within the limits of the screen's work area (the portion of the screen not used by the system taskbar or by application desktop toolbars) and move it if not.

procedure TfrmMain.OnMove(var Msg: TWMMove);
var
  WorkArea: TRect;
begin
  inherited;
  if SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0) then
  begin
    if Left < WorkArea.Left then
      Left := WorkArea.Left
    else if Left + Width > WorkArea.Right then
      Left := WorkArea.Right - Width;
    if Top < WorkArea.Top then
      Top := WorkArea.Top
    else if Top + Height > WorkArea.Bottom then
      Top := WorkArea.Bottom - Height;
  end;
end;

The full source code of this example is available for download:

http://www.latiumsoftware.com/download/p0020.zip


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

How to strip numbers from an alphanumeric string

Problem/Question/Abstract:

How to strip numbers from an alphanumeric string

Answer:

function.StripNonNums(AText: string): string;
var
  i: integer;
  r: integer;
begin
  SetLength(Result, Length(AText));
  r := 1;
  for i := 1 to Length(AText) do
    if AText[i] in ['0'..'9'] then
    begin
      Result[r] := AText[i];
      Inc(r);
    end;
  SetLength(Result, r);
end;

How to blend two TBitmap's (2)

Problem/Question/Abstract:

I need to draw semi-transparent rectangles to highlight areas over an image. Any clues as to how to do this?

Answer:

This is particularly neat to use if you want to place text on a bitmap and guarantee that the text is readable without completely obscuring the image underneath; simply tint the area underneath the text with clBlack, then draw clWhite text on top (with Canvas.Brush.Style = bsClear).

Note that the TintBitmapRect procedure below requires that you're using pf32Bit bitmaps. It can be modified to work with other pixel formats, but that is an exercise for the reader.

{TColors have color components in blue-green-red order. 32-bit
bitmap pixels have color components in red-green-blue order. This function
allows conversion between the two orders.}

function SwapRedBlue(const Color: TColor): TColor;
begin
  Result := (Color and $FF0000) shr 16 or (Color and $00FF00) or (Color and $0000FF) shl 16;
end;

{Tint an arbitrary rectangular area of a bitmap with an arbitrary color}

procedure TintBitmapRect(const Bitmap: TBitmap; const Rect: TRect; const Color: TColor);
var
  Pixel: PLongWord;
  I: Integer;
  J: Integer;
  Color2: LongWord;
const
  Mask: LongWord = $00FEFEFE;
begin
  Assert(Bitmap.PixelFormat = pf32Bit);
  Color2 := SwapRedBlue(Color) and Mask;
  for I := Rect.Top to (Rect.Bottom - 1) do
  begin
    Pixel := Bitmap.ScanLine[I];
    Inc(Pixel, Rect.Left);
    for J := Rect.Left to (Rect.Right - 1) do
    begin
      Pixel^ := ((Pixel^ and Mask) + Color2) shr 1;
      Inc(Pixel);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  with Image1.Picture do
  begin
    Bitmap.PixelFormat := pf32Bit;
    TintBitmapRect(Bitmap, Rect(Bitmap.Width div 4, Bitmap.Height div 4,
      Bitmap.Width - Bitmap.Width div 4,
      Bitmap.Height - Bitmap.Height div 4), clRed);
  end;
end;

Disable the select and copy to clipboard capabilities in a TMemo

Problem/Question/Abstract:

How to disable the select and copy to clipboard capabilities in a TMemo

Answer:

Solve 1:

Use OnKeyDown and OnKeyPress handlers for the memo to catch the shortcuts for copy and cut and set key := 0 for them. Provide a handler for the OnContextMenu event in which you set Handled to true to prevent the default popup menu from coming up. That should do it.

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if ssCtrl in Shift then
    case Key of
      Ord('C'), Ord('X'), VK_INSERT: Key := 0;
    end
  else if (ssShift in Shift) and (Key = VK_DELETE) then
    Key := 0;
end;

procedure TForm1.Memo1ContextPopup(Sender: TObject; MousePos: TPoint;
  var Handled: Boolean);
begin
  Handled := true;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
  if Key in [^C, ^X] then
    Key := #0;
end;


Solve 2:

The easiest way would be to set the Enabled property of the Memo (or Edit) control to False so that the control cannot receive events. This drawback to this method is the user won't be able to scroll the text and the disabled text looks bad.

In order to prevent the user from writing in the memo, we set its ReadOnly property to True.

To prevent the user from selecting text with the mouse, we generate the handler of the MouseMove event of the control and write the following code:

procedure TForm1.Memo1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then
    Memo1.SelLength := 0;
end;

In order to prevent the user from performing a selection using the keyboard, we generate the handlers of the KeyDown and KeyUp events, assigning the OnKeyDown and OnKeyUp properties to the same procedure:

procedure TForm1.Memo1KeyDownUp(Sender: TObject;
  var Key: Word; Shift: TShiftState);
begin
  if (ssShift in Shift) and (Key in [VK_LEFT, VK_RIGHT, VK_UP,
    VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END]) then
    Key := 0;
end;

How to eject and close a CD-ROM drive

Problem/Question/Abstract:

How to eject and close a CD-ROM drive

Answer:

Solve 1:

To open the CD-ROM:


mciSendString('Set cdaudio door open wait', nil, 0, handle);


To close the CD-ROM:


mciSendString('Set cdaudio door closed wait', nil, 0, handle);


Remember to include the MMSystem unit in your uses clause. Also note that you will get a Blue Screen on certain hardware, if you use this code.


Solve 2:

function CdClose(const Value: char): integer;
var
  strCommand: string;
  strError: array[0..MAX_PATH] of char;
begin
  strCommand := 'open ' + Value + ': type cdaudio alias xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'set xxx door closed';
  Result := MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'close xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  if Result <> 0 then
    MCIGetErrorString(Result, strError, 255);
  MessageDlg(strError, mtError, [mbOK], 0);
end;

function CdOpen(const Value: char): integer;
var
  strCommand: string;
  strError: array[0..MAX_PATH] of char;
begin
  strCommand := 'open ' + Value + ': type cdaudio alias xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'set xxx door open';
  Result := MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'close xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  if Result <> 0 then
    MCIGetErrorString(Result, strError, 255);
  MessageDlg(strError, mtError, [mbOK], 0);
end;


Solve 3:

procedure mcicheck(R: Cardinal);
var
  S: array[0..1023] of Char;
begin
  if R = 0 then
    exit;
  mciGetErrorString(R, S, SizeOf(S) - 1);
  raise Exception.Create(S);
end;

procedure MoveCDDoor(const Drive: string; Open: Boolean);
const
  Direction: array[Boolean] of Cardinal = (MCI_SET_DOOR_CLOSED, MCI_SET_DOOR_OPEN);
var
  OP: TMCI_Open_Parms;
  id: Cardinal;
begin
  Fillchar(OP, SizeOf(OP), 0);
  OP.lpstrDeviceType := PChar(MCI_DEVTYPE_CD_AUDIO);
  OP.lpstrElementName := PChar(Drive);
  mcicheck(mciSendCommand(0, MCI_OPEN, MCI_WAIT or MCI_OPEN_TYPE or
    MCI_OPEN_TYPE_ID or MCI_OPEN_ELEMENT, Cardinal(@OP)));
  id := OP.wDeviceID;
  try
    mcicheck(mciSendCommand(id, MCI_SET, MCI_WAIT or Direction[Open], 0));
  finally
    mcicheck(mciSendCommand(id, MCI_CLOSE, MCI_WAIT, 0));
  end;
end;


Solve 4:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEREMOVECOMPLETE = $8004;
  DBT_DEVTYP_VOLUME = 2; {logical volume}

type
  _DEV_BROADCAST_VOLUME = record
    dbcv_size,
      dbcv_devicetype,
      dbcv_reserved,
      dbcv_unitmask: DWORD;
    dbcv_flags: WORD;
  end;
  TDevBroadcastVolume = _DEV_BROADCAST_VOLUME;
  PDevBroadcastVolume = ^TDevBroadcastVolume;

procedure TForm1.WMDeviceChange(var Msg: TMessage);
var
  Disques: set of 0..25;
  nDisque: Integer;
  sMsg: string;
  Volume: PDevBroadcastVolume;
begin
  inherited;
  case Msg.WParam of
    DBT_DEVICEARRIVAL:
      sMsg := 'Disk inserted :';
    DBT_DEVICEREMOVECOMPLETE:
      sMsg := 'Disk ejected :';
  else
    Exit;
  end;
  Volume := PDevBroadcastVolume(Msg.LParam);
  if Volume^.dbcv_devicetype <> DBT_DEVTYP_VOLUME then
    Exit;
  DWORD(Disques) := Volume^.dbcv_unitmask;
  for nDisque := 0 to 25 do
  begin
    if not (nDisque in Disques) then
      Continue;
    sMsg := sMsg + #13 + Char(nDisque + Ord('A')) + ':\';
  end;
  ShowMessage(sMsg);
end;

end.

How to retrieve the icons of a MessageBox

Problem/Question/Abstract:

How can I retrieve the MessageBox images (MB_ICONINFORMATION, MB_ICONERROR etc.) for use in a TListView?

Answer:

You can use the LoadIcon API to get the images:

procedure TForm1.Button1Click(Sender: TObject);
const
  Size = 6;
  IconArray: array[0..Size - 1] of PChar = (IDI_APPLICATION, IDI_ASTERISK,
    IDI_EXCLAMATION,
    IDI_HAND, IDI_QUESTION, IDI_WINLOGO);
begin
  Image1.Picture.Icon.Handle := LoadIcon(0, IconArray[5]);
end;

How to set the private directory to the applications' subdirectory

Problem/Question/Abstract:

I'm wondering how one can set the privatedir. I don't mean in my program, but just so I know where the temp files go. Does the BDEcfg program do that? If so, where? I'm using BDE 4.0

Answer:

Your program sets the private directory, it's not in the cfg. If you don't set it in your program it defaults to the apps directory. If your app resides on a server in a multiple use environment this is not what you want. I add the following code to all my apps (I also limit my apps to one instance):

s := ' C:\AZPC\PRIVATE\' + ChangeFileExt(ExtractFileName(Application.ExeName), '.');
if not DirectoryExists(s) then
begin
  ForceDirectories(s);
  if not DirectoryExists(s) then
    ShowMessage('Unable to find and/or create the ' + #10 + s + #10 + ' directory '
      + #10 + ' the program will run, but not be fully functional.');
end;
Session.PrivateDir := s;

This sets the private directory to the exe name subdirectory on the C: drive.