Create a TBitmap from a two-dimensional array of byte

Problem/Question/Abstract:

Is there an easy way of converting a two dimensional array of byte to a bitmap?

Answer:

Depending on your PixelFormat (example is for 8 bit bitmap)...

{ ... }
var
  Ptr: ^Byte; {for 8 bit PixelFormat}
begin
  NewBitmap := TBitmap.Create;
  NewBitmap.PixelFormat := pf8bit;
  NewBitmap.Height := High(PixelArray); { assumes Low(PixelArray) = 0; }
  NewBitmap.Width := High(PixelArray[0]); { assumes Low(PixelArray[0]) = 0; }
  for y := 0 to NewBitmap.Height - 1 do
  begin
    Ptr := NewBitmap.ScanLine[y];
    for x := 0 to NewBitmap.Width - 1 do
    begin
      Ptr^ := PixelArray[y, x];
      Inc(Ptr);
    end;
  end;
end;

Send binary data from a CGI application

Problem/Question/Abstract:

Set the default file name for saving the data provided as 'response'.

Answer:

It is pretty easy to return any kind of data inside a Delphi CGI Application. But sometimes the data has to be saved under a certain filename, such as "Test.ZIP". To do this you need to add the HTTP header item "Content-Disposition".
To do it in Delphi use the CustomHeaders property. To this TStrings property you can add items in the syntax "name=value" - surprisingly the HTTP syntax name:value is not used here. Example:

procedure TWebModule1.WebModule1CHECKSTATUSAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: TFileStream;
begin
  s := nil;
  if request.query = 'download' then
  try
    response.Title := 'Download Test.ZIP';
    response.CustomHeaders.Add('Content-Disposition=filename=Test.zip');
    response.ContentType := 'application/zip';
    s := TFileStream.Create(fmOpenRead + fmShareDenyNone, 'Test.zip');
    response.contentstream := s;
    response.sendresponse;
  finally
    s.Free;
  end;
end;

Object Inspector Shortcuts

Problem/Question/Abstract:

Object Inspector Shortcuts

Answer:

To display the Object Inspector's component pop-up menu, press [Ctrl][DownArrow]. This is a convenient way to select a component that's behind another component. To quickly select a specific component from the menu, press the key that corresponds to the first letter of the component's name.

If the names of several components start with the same letter, pressing the letter key again will move the focus to the next component in the menu that starts with that letter. (In other words, typing the full name doesn't help.)

To expand or collapse a nested property (such as Font, which defines subproperties such as Color or Height), select the property and press [Alt][F10], and then choose Expand or Collapse from the Object Inspector speed menu.

When the Object Inspector is active, you can toggle between the Properties and Events pages by pressing [Ctrl][Tab]. If you set your editor to IDE classic, as I prefer, you may use F6 for this as well.

To select a specific property or event, obviously you can use the arrow keys or the [PageUp] and [PageDown] keys. However, you can also select a property or event by name by pressing [Tab] to move the focus to the names and values, and then typing the first letter of the property or event name.

If you mistype a name and need to start again, press [Esc] once to return the focus to the beginning of the names. When you've selected the correct property or event, press [Tab] to move the focus from the name to the value.

Generate the SELECT-statement in run-time

Problem/Question/Abstract:

Generate the script for SELECT-statement

Answer:

I want to publish a small procedure that generate a SELECT-statement for data of table. This code I uses in DIM: Database Information Manager (http://www.scalabium.com/download/dbinfo.zip):

function GetSelectTable(Dataset: TTable): TStrings;
var
  i: Integer;
  str: string;
begin
  Result := TStringList.Create;
  try
    for i := 0 to DataSet.FieldCount - 1 do
    begin
      if i = 0 then
        str := 'SELECT'
      else
        str := ',';
      str := str + ' ' + DataSet.Fields[i].FieldName;
      Result.Add(str);
    end;
    Result.Add('FROM ' + DataSet.TableName)
  except
    Result.Free;
    Result := nil;
  end;
end;

Of course, you can add the ORDER BY-clause (just iterate by index fields)...

Windows detection routines

Problem/Question/Abstract:

Here is how to find out almost everything of windows versions.

Answer:

function IsWin31: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  Result := (Os.dwPlatformId = VER_PLATFORM_WIN32s);
end;

function IsWin95: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := (OS.dwMajorVersion >= 4) and (OS.dwMinorVersion = 0) and (OS.dwPlatformId
    = VER_PLATFORM_WIN32_WINDOWS);
end;

function IsWin95OSR2: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := (OS.dwMajorVersion >= 4) and (OS.dwMinorVersion = 0) and
    (lo(OS.dwBuildNumber) > 1000) and (OS.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS);
end;

function IsWinNT: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := OS.dwPlatformId = VER_PLATFORM_WIN32_NT;
end;

function IsWin98: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := (OS.dwMajorVersion >= 4) and (OS.dwMinorVersion > 0) and (OS.dwPlatformId
    = VER_PLATFORM_WIN32_WINDOWS);
end;

function IsWin98se: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := (OS.dwMajorVersion >= 4) and (OS.dwMinorVersion > 0) and
    (lo(OS.dwBuildNumber) > 2000) and (OS.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS);
end;

function IsWin2000: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := (OS.dwMajorVersion >= 5) and (OS.dwPlatformId = VER_PLATFORM_WIN32_NT);
end;

function IsWinXP: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := (OS.dwMajorVersion >= 5) and (OS.dwMinorVersion >= 1) and (OS.dwPlatformId
    = VER_PLATFORM_WIN32_NT);
end;

function IsWinMe: Boolean;
var
  OS: TOSVersionInfo;
begin
  ZeroMemory(@OS, SizeOf(OS));
  OS.dwOSVersionInfoSize := SizeOf(OS);
  GetVersionEx(OS);
  result := (OS.dwMajorVersion >= 4) and (OS.dwMinorVersion >= 90) and (OS.dwPlatformId
    = VER_PLATFORM_WIN32_WINDOWS);
end;

function GetNTType: string;
var
  r: TRegistry;
  ts: string;
begin

  Result := '[UNKNOWN]';

  if IsWinNT then
  begin
    r := TRegistry.Create;
    r.RootKey := HKEY_LOCAL_MACHINE;
    r.OpenKey('SYSTEM\CurrentControlSet\Control\ProductOptions', False);
    ts := AnsiUpperCase(R.ReadString('ProductType'));
    r.Free;
    if (ts = 'WINNT') then
    begin
      result := 'Workstation';
      if IsWin2000 then
        result := 'Professional';
    end
    else if (ts = 'SERVERNT') then
    begin
      result := 'Server';
    end
    else if (ts = 'LANMANNT') then
    begin
      result := 'Advanced Server';
    end;
  end;

end;

How to draw a TRadioGroup without a frame

Problem/Question/Abstract:

How to draw a TRadioGroup without a frame

Answer:

unit GSRadioGroup;

interface

uses
  Windows, SysUtils, Classes, Forms, ExtCtrls;

type
  TGSRadioGroup = class(TRadioGroup)
  private
    FBorderStyle: TBorderStyle;
    FValues: TStrings;
  protected
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure Paint; override;
    function GetValues: TStrings;
    procedure SetValues(Value: TStrings);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
    property Values: TStrings read GetValues write SetValues;
  end;

procedure Register;

implementation

constructor TGSRadioGroup.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBorderStyle := bsNone;
  FValues := TStringList.Create;
end;

destructor TGSRadioGroup.Destroy;
begin
  FValues.Free;
  inherited Destroy;
end;

function TGSRadioGroup.GetValues;
begin
  Result := FValues;
end;

procedure TGSRadioGroup.SetValues(Value: TStrings);
begin
  if Value <> FValues then
  begin
    FValues.Assign(Value);
  end;
end;

procedure TGSRadioGroup.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TGSRadioGroup.Paint;
var
  c: Integer;
  diff: Integer;
  H: Integer;
  R: TRect;
begin
  if FBorderStyle = bsSingle then
    inherited Paint
  else
  begin
    with Canvas do
    begin
      if Text <> EmptyStr then
      begin
        Font := Self.Font;
        H := TextHeight('0');
        R := Rect(8, 0, 0, H);
        DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or DT_SINGLELINE or DT_CALCRECT);
        Brush.Color := Color;
        DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or DT_SINGLELINE);
      end
      else
      begin
        if ControlCount > 0 then
        begin
          diff := Controls[0].Top;
          for c := 0 to ControlCount - 1 do
          begin
            Controls[c].Top := Controls[c].Top - diff;
          end;
          {You may want to adjust the height here}
        end;
      end;
    end;
  end;
end;

procedure Register;
begin
  RegisterComponents('Garlin', [TGSRadioGroup]);
end;

end.

How to reverse a string

Problem/Question/Abstract:

How to reverse a string

Answer:

Here are three examples how to reverse a string:


#1, While easy to understand suffers from a lot of memory reallocation. Each time the next letter is added to s2, it's added to the beginning of the string causing a reallocation of the entire string.


function ReverseString(s: string): string;
var
  i: integer;
  s2: string;
begin
  s2 := '';
  for i := 1 to Length(s) do
    s2 := s[i] + s2;
  Result := s2;
end;


#2, Taking advantage of the fact that we can work at both ends of the string at once AND the fact that IF there is a middle character, ie. an odd number of characters in the string, it doesn't change position at all and we can eliminate all the memory allocations, work completely within the source string swapping from end to end working toward the middle and only having to make 1/2 of a loop through the string.



procedure ReverseStr(var Src: string);
var
  i, j: integer;
  C1: char;
begin
  j := Length(Src);
  for i := 1 to (Length(Src) div 2) do
  begin
    C1 := Src[i];
    Src[i] := Src[j];
    Src[j] := C1;
    Dec(j);
  end;
end;


#3, One disadvantage of #2 can be seen when trying to fill one control with the contents of another.  For example, two TEdits.  Since TEdit.Text can't be sent as a var parameter you'll need to first make use of a temporary string and then set the second TEdit:


var
  tStr: string;
begin
  tStr := Edit1.Text;
  ReverseStr(tStr);
  Edit2.Text := tStr;


However, using #3 this code turns into,


Edit2.Text := ReverseStr(Edit1.Text);

In addition, we lost 1 local var and the loop body was reduced since we could use Result directly swapping as we go!


function ReverseStr(const Src: string): string;
var
  i, j: integer;
begin
  j := Length(Src);
  SetLength(Result, j);
  for i := 1 to (Length(Src) div 2) do
  begin
    Result[i] := Src[j];
    Result[j] := Src[i];
    Dec(j);
  end;
end;

How to really make a resource file

Problem/Question/Abstract:

Creating a sort of uncompressed Zip file to store all the files required for a game or any other program that requires additional files.

Answer:

Instead of having loads of files for your games distributed all over the place, you can stick all your files into a single package, you find these used in almost every game out.

To make these files requires a header which can be a set length then all the files, followed by each files information in equal segments:

[HEADER]
[FILE1]
[FILE2]
...
[FILEN]
[FILE1INFO]
[FILE2INFO]
...
[FILENINFO]

this can easily be achieved and you can have lots of other 'addins' such as putting files in sub directories, special properties being set for each file etc....

first off you need a header, this usually consists of 4 things

type
  header = record
    Signature: array[1..4] of char;
    Version: LongInt;
    fileoffset: LongInt;
    fileentries: LongInt;
  end;

The signiture could be anything that you wish, but it is used for checking if the file is a valid package file for your program. next is the version, you may wish to improve the package file over time or have an increment system for your application so that a file in an newer package, determined by the version number would overide that of a file in an older package.

Next is the fileoffset, this points to the begining of the file info section after the last file in the package.

FILEENTRIES is used for counting how many file info entries there are, so u can have a loop running reading off the entries if you so wished.

so create ur file then write in the header

wfile.Write(head, SizeOf(head));

next comes the adding of the actual files this can be done by using TFileStream then

rfile.create('filename', fmopenread);

wfile.copyfrom(rfile, rfile.size);

continue writing the files next comes writing the file info, this must be done either after adding all the files or while adding one file to the final file you create a temporary file and add the file info to the file then, then when finished 'stick' the temp file onto the end of the final file. There is other options available, but they are upto you to discover.

The File Info entries MUST be all of the same size for this example i have used 44 bytes but you could use anything aslong as it is the same, having large file info entries will dramatically increase your file size so i would sujest someting around 44 bytes.

type
  tfilenametype = array[0..29] of char;
  direntry = record
    offset: longint;
    size: longint;
    filename: tfilenametype;
    timestamp: longint;
  end;

offset = the position from the begining of the package file. and the size value = the size of that file it refrences. so that you can seek and read the file out of the package. Filename is obvious and the timestamp would be

fileage('filename');

add this all into a file and then u have your package, reading it is just of case of reading instead of writing the file, but using this as a guide you could take this far.

Check this GDC article if this is not enought for you.

Registering an ActiveX for its class

Problem/Question/Abstract:

How getting the IUnknown reference on a specific COM object's instance created by an application ?

Answer:

The RegisterActiveObject function -from the Win32 API- can register an object by passing its IUnknown reference and its CLSID to make it the active object for its CLSID.
Registration causes the object to be listed in OLE's running object table, a globally accessible lookup table that keeps track of the objects that are currently running on your computer.
An application can then create an OLE automation object for example, register it as the active object at startup.
Other application can have access to this particular instance by getting a IDispatch reference with the Delphi's GetActiveOleObject using its progID.

I've placed the registration mecanism in the TActiveObject class showed bellow and you can download the demo applications.

unit ActiveObject;

// Written by Bertrand Goetzmann (http://www.object-everywhere.com)
// Keywords : RegisterActiveObject, CoLockObjectExternal, RevokeActiveObject, CoDisconnectObject, GetActiveOleObject, GetActiveObject

interface

type
  TActiveObject = class
  private
    FUnk: IInterface;
    FRegister: Integer;
  public
    constructor Create(Unk: IInterface; const clsid: TGUID); overload;
    constructor Create(Unk: IInterface; const ProgId: string); overload;
    destructor Destroy; override;
  end;

implementation

uses ActiveX, ComObj;

{ TActiveObject }

constructor TActiveObject.Create(Unk: IInterface; const clsid: TGUID);
begin
  inherited Create;
  FUnk := Unk;
  OleCheck(RegisterActiveObject(FUnk, clsid, ACTIVEOBJECT_WEAK, FRegister));
  OleCheck(CoLockObjectExternal(FUnk, True, True));
end;

constructor TActiveObject.Create(Unk: IInterface; const ProgId: string);
begin
  Create(Unk, ProgIDToClassID(ProgId));
end;

destructor TActiveObject.Destroy;
begin
  OleCheck(CoLockObjectExternal(FUnk, False, True));
  OleCheck(RevokeActiveObject(FRegister, nil));
  OleCheck(CoDisconnectObject(FUnk, 0));
  inherited;
end;

end.

In the demo applications, OleObject.dll is the implementation of the OLE automation object with "OleObject.Test" as progId and supporting the ITest interface. This interface has a single property named Message : you can read or write a simple string of characters.
The AppTest.exe creates an instance of this OLE automation object and register it with an instance of TActiveObject. When the applicatino shut down, the registration of the active objet is revoked.
Start several instances of ClientTest. ClientTest gets the IDispatch reference, via a Variant variable, on the active object by using a call of GetActiveOleObject('OleObject.Test'), to set or get the Message property value.

I think it is a powerful way to make applications more collaborative.


Component Download: http://perso.worldonline.fr/objecteverywhere/ActiveObject.zip

Revert all controls on a TForm to design-time values when clicking on a button at runtime

Problem/Question/Abstract:

Is it possible to reset the state of controls like TEdit.text, TCheckBox.Checked, etc. at runtime to their original design-time values without assigning the property values for each control again?

Answer:

If I understand you correctly you want all controls on the form to revert to the design-time values when the user clicks the a cancel button, for example. The generic way would be to reload the controls from the form resource. The main problem is that you have to delete all components on the form first or you get a load of errors since the component loading code really creates new instances of all components on the form.

unit Unit1;

interface

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

const
  UM_RELOADFORM = WM_USER + 321;

type
  TForm1 = class(TForm)
    Button1: TButton;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    RadioGroup1: TRadioGroup;
    RadioGroup2: TRadioGroup;
    CheckBox4: TCheckBox;
    CheckBox5: TCheckBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure UMReloadForm(var msg: TMessage); message UM_RELOADFORM;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  {Delay action until button click code has finished executing}
  PostMessage(handle, UM_RELOADFORM, 0, 0);
end;

procedure TForm1.UMReloadForm(var msg: TMessage);
var
  i: Integer;
  rs: TResourceStream;
begin
  {Block form redrawing}
  Perform(WM_SETREDRAW, 0, 0);
  try
    {Delete all components on the form}
    for i := ComponentCount - 1 downto 0 do
      Components[i].Free;
    {Find the forms resource}
    rs := TResourceStream.Create(FindClassHInstance(TForm1), Classname, RT_RCDATA);
    try
      {Recreate components from the form resource}
      rs.ReadComponent(self);
    finally
      rs.free
    end;
  finally
    {Redisplay form}
    Perform(WM_SETREDRAW, 1, 0);
    Invalidate;
  end;
end;

end.

Queue up message forms in a TStringList

Problem/Question/Abstract:

I use a timer to check some conditions. If something special happens, I display a message form (using MyMessage.ShowModal, because I need an answer from the user). The timer goes on, so several of this Messages could be displayed simultaneously. What I want to do: Queue this messages and just display one. If the message is done, the next one is to be displayed.

Answer:

Simple idea: Instead of immediately popping up each message, queue them up into a stringlist. With a second timer (set to an appropriate interval) , process the message list, and delete/ take action. See example below (variations with enabling/ disabling timer2 are possible)

procedure TForm1.FormCreate(Sender: TObject);
begin
  MsgList := TStringList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  MsgList.Free;
end;

{check for abnormal conditions}

procedure TForm1.Timer1Timer(Sender: TObject);
const
  msgNumber: integer = 0;
begin
  if Random > 0.5 then
  begin
    MsgList.Add('message ' + IntToStr(msgNumber) + ' @ ' + TimeToStr(Now));
    inc(MsgNumber);
  end;
end;

{process messages}

procedure TForm1.Timer2Timer(Sender: TObject);
begin
  Timer2.Enabled := false; {extremely important !}
  while MsgList.Count > 0 do
  begin
    {show oldest messages first}
    ShowMessage(MsgList[0] + ' viewed @' + TimeToStr(Now));
    MsgList.Delete(0);
    {your specific actions ...}
  end;
  Timer2.Enabled := true;
end;

How to save multiple records and an integer into one file

Problem/Question/Abstract:

I am writing an adventure game and need to store information in a save game. The game requires data from 3 different records and one variable

record1 = hotspot scene information(50 recs),
record2 = conversation information (60 recs),
record3 = hypertext information(50 recs)
variable = integer - # of scene currently on.

My problem is that I need to seek for a particular record of particular type in the file (I do not want to have to keep huge arrays of records in memory). I know how to do this with a file containing records of only one record type but have no clue how to combine all three records and one integer into a single random access file.

Answer:

I generally use a file with a header, then just keep the header in memory and use it to seek to the records I need.

type
  TSaveHeader = record
    scene: Integer;
    hotspots: LongInt;
    talk: LongInt;
    hype: LongInt;
  end;

var
  SaveHeader: TSaveHeader;

procedure OpenSaveFile(fname: string);
var
  f: file;
  i: Integer;
begin
  AssignFile(f, fname);
  Reset(f, 1);
  BlockRead(f, SaveHeader, Sizeof(TSaveHeader));
  { get one set of records }
  Seek(f, SaveHeader.hotspots);
  for i := 1 to 50 do
    BlockRead(f, somevar, sizeof_hotspotrec);
  { and so on }
  CloseFile(f);
end;

{ assuming the file is open }

procedure GetHotspotRec(index: LongInt; var hotspotrec: THotspot);
var
  offset: LongInt;
begin
  offset := SaveHeader.hotspots + index * Sizeof(THotSpot);
  Seek(f, offset);
  BlockRead(f, hotspotrec, Sizeof(THotspot));
end;

Searching Strings by the way they sound (2)

Problem/Question/Abstract:

How to match strings based on the way they sound & not on their spellings.

Answer:

This article is in continuation of my previous article "Searching Strings by the way they sound" and represents an attempt at making the SoundEx() more versatile so as to theoratically accomodate languages other than English - the only restriction being that the language should use the ASCII character set. Another advantage is that the function can be "tuned" to peculiarities of a language e.g. "Knife" is pronounced as "Nife" in English. There is theoratically no limit to this "tunability" - of course with corresponding decrease in performance. But you can get amazing results which are better than what SoundEx() gives.

I have chosen to post a new article rather than update the original one since the original function has been modified quite significantly (in concept) thus making it different from the industry standard SoundEx() function - which was implemented in the original article.

Since the function now supports language "tuning", it can give different results than the industry standard SoundEx(). I have thus renamed the function to "Sound()". This also gives me the freedom to implement it differently.

Sound() returns the same value (M240) for each of Micael/Maical/Michael/Maichael. Additionally, since it has been (partially) tuned for English, it will give the same result (F500) for "Phone"/"Fone".

I guess the "Ultimate" Sound Matching logic will be based on phonemes - of which I currently know very little. If you help me by providing me details of phonemes that you may have, then I will make yet another attempt at improving "Sound()" even further...

I thank Toninho Nunes and Joe Meyer for providing me ideas & inputs respectively.

Please save the code below in a file called "Sounds.pas". You will need to include the file in your source (Uses Sounds) and then you will have access to the Sound() function.

{********************************************************************}
{* Description: Modified Soundex function in which it is attempted to include *}
{* language pecularities which theoratically makes it adaptable to languages  *}
{* other than English - the only restriction being that the language in       *}
{* question should use ASCII character set                                    *}
{********************************************************************}
{* Date Created  : 15-Nov-2000                                                *}
{* Last Modified : 16-Nov-2000                                                *}
{* Version       : 0.10                                                       *}
{* Author        : Paramjeet Reen                                             *}
{* eMail         : Paramjeet.Reen@EudoraMail.com                              *}
{******************************************************************************}
{* This program is based on an algorithm that I had found in a magazine,      *}
{* merged with an algorithm of a program posted by Joe Meyer. I do not        *}
{* gurantee the fitness of this program in any way. Use it at your own risk.  *}
{********************************************************************}
{* Category: Freeware.                                                        *}
{********************************************************************}

unit Sounds;

interface

//Returns a code for InpStr depending upon how it sounds.
function Sound(const InpStr: ShortString): ShortString;

implementation

type
  TReplacePos = (pStart, pMid, pEnd);
  TReplacePosSet = set of TReplacePos;

const
  {********************************************************************}
  {* The following are selected letters of the alphabet which are divided     *}
  {* into their corresponding code (1-6). You might need to modify these for  *}
  {* different languages depending upon whether the language requires         *}
  {* alphabets other than the ones specified below                            *}
  {********************************************************************}
  Chars1 = ['B', 'P', 'F', 'V'];
  Chars2 = ['C', 'S', 'K', 'G', 'J', 'Q', 'X', 'Z'];
  Chars3 = ['D', 'T'];
  Chars4 = ['L'];
  Chars5 = ['M', 'N'];
  Chars6 = ['R'];

procedure ReplaceStr(var InpStr: ShortString; const SubStr, WithStr: ShortString;
  const ReplacePositions: TReplacePosSet);
var
  i: Integer;
begin
  if (pStart in ReplacePositions) then
  begin
    i := Pos(SubStr, InpStr);

    if (i = 1) then
    begin
      Delete(InpStr, i, Length(SubStr));
      Insert(WithStr, InpStr, i);
    end;
  end;

  if (pMid in ReplacePositions) then
  begin
    i := Pos(SubStr, InpStr);

    while (i > 1) and (i <= (Length(InpStr) - Length(SubStr))) do
    begin
      Delete(InpStr, i, Length(SubStr));
      Insert(WithStr, InpStr, i);
      i := Pos(SubStr, InpStr);
    end;
  end;

  if (pEnd in ReplacePositions) then
  begin
    i := Pos(SubStr, InpStr);

    if (i > 1) and (i > (Length(InpStr) - Length(SubStr))) then
    begin
      Delete(InpStr, i, Length(SubStr));
      Insert(WithStr, InpStr, i);
    end;
  end;
end;

function Sound(const InpStr: ShortString): ShortString;
var
  vStr: ShortString;
  PrevCh: Char;
  CurrCh: Char;
  i: Word;
begin
  {********************************************************************}
  {* Uppercase & remove invalid characters from given string                  *}
  {********************************************************************}
  {* Please have a long & hard look at this code if you have modified any of  *}
  {* the constants Chars1,Chars2 ... Chars6 by increasing the overall range   *}
  {* of alphabets                                                             *}
  {********************************************************************}
  vStr := '';
  for i := 1 to Length(InpStr) do
    case InpStr[i] of
      'a'..'z': vStr := vStr + UpCase(InpStr[i]);
      'A'..'Z': vStr := vStr + InpStr[i];
    end; {case}

  if (vStr <> '') then
  begin
    {**************************************************************************}
    {* Language Tweaking Section                                              *}
    {********************************************************************}
    {* Tweak for language peculiarities e.g. "CAt"="KAt", "KNIfe"="NIfe"      *}
    {* "PHone"="Fone", "PSYchology"="SIchology", "EXcel"="Xcel" etc...        *}
    {* You will need to modify these for different languages. Optionally, you *}
    {* may choose not to have this section at all, in which case, the output  *}
    {* of Sound() will correspond to that of SoundEx(). Please note however   *}
    {* the importance of what you replace & the order in which you replace.   *}
    {********************************************************************}
    {* Also, please note that the following replacements are targeted for the *}
    {* English language & that too is subject to improvements                 *}
    {********************************************************************}
    ReplaceStr(vStr, 'CA', 'KA', [pStart, pMid, pEnd]); //arCAde = arKAde
    ReplaceStr(vStr, 'CL', 'KL', [pStart, pMid, pEnd]); //CLass  = Klass
    ReplaceStr(vStr, 'CK', 'K', [pStart, pMid, pEnd]); //baCK   = baK
    ReplaceStr(vStr, 'EX', 'X', [pStart, pMid, pEnd]); //EXcel  = Xcel
    ReplaceStr(vStr, 'X', 'Z', [pStart]); //Xylene = Zylene
    ReplaceStr(vStr, 'PH', 'F', [pStart, pMid, pEnd]); //PHone  = Fone
    ReplaceStr(vStr, 'KN', 'N', [pStart]); //KNife  = Nife
    ReplaceStr(vStr, 'PSY', 'SI', [pStart]); //PSYche = SIche
    ReplaceStr(vStr, 'SCE', 'CE', [pStart, pMid, pEnd]); //SCEne  = CEne

    {********************************************************************}
    {* String Assembly Section                                                *}
    {********************************************************************}
    PrevCh := #0;
    Result := vStr[1];
    for i := 2 to Length(vStr) do
    begin
      if Length(Result) = 4 then
        break;

      CurrCh := vStr[i];
      if (CurrCh <> PrevCh) then
      begin
        if CurrCh in Chars1 then
          Result := Result + '1'
        else if CurrCh in Chars2 then
          Result := Result + '2'
        else if CurrCh in Chars3 then
          Result := Result + '3'
        else if CurrCh in Chars4 then
          Result := Result + '4'
        else if CurrCh in Chars5 then
          Result := Result + '5'
        else if CurrCh in Chars6 then
          Result := Result + '6';

        PrevCh := CurrCh;
      end;
    end;
  end
  else
    Result := '';

  while (Length(Result) < 4) do
    Result := Result + '0';
end;

end.

Saving List Box Data at Runtime (TFileStream)

Problem/Question/Abstract:

How do I save data entered in a list box at run time without resorting to a text file or having to deal with the overhead of a table?

Answer:

Note: A sample program is available. Even though this article focuses on saving a list box at runtime, it really presents a general overview of using the TFileStream class for streaming components to and from disk. This is an important distinction to make because while I use the TListBox as an example, it is possible to apply the concepts to almost all components.

Any OOP class library worth its salt supports what is called streamable persistent objects. Simply put, this means that an instance of a class (or at least its data) can be saved to a disk file and restored later. When a program reloads the object, it is restored in its last state, just prior to being written. The cool thing about this is that the program doesn't have to have any advance knowledge of the state of the object; the object itself contains all the information it needs to recreate itself when it's restored.

For example, let's say you've created a program that has a list box in which people append various bits of information at run time. For many folks, saving the information to disk means iterating through all the items in the list and writing them to a text file or even a table. The program must reload the data from the external file and add the data, line by line. This is not so bad, but it can be a bit of a chore to write the code.

On the other hand, using object persistence, the same program mentioned above instructs the list box to write its data to a disk file of some sort. When it wants to reload the object, all it has to do is stream it back into memory and specify the base class to write to. Remember, since all the data of the object was saved with it when it was written to disk, the object comes back to life in its original form. That's the whole idea behind object persistence.

Delphi itself makes heavy use of object persistence. Every time you save a project, it streams out to disk the data contained in your objects' properties so that everything you set during your session is saved. When you reload a project, Delphi streams the object data back into your form(s) to restore everything you previously set. In fact, a form file itself is streamed to and from disk. I should note here that Delphi uses a couple of specialized stream classes, TWriter and TReader which are derived from a superclass called TFiler. I won't go into the details of these classes here, since I'm providing a much simpler demonstration of employing object persistence in your programs. I'll leave it up to you to research this topic further.

Moving on, you might ask, "Where does employing streamable persistent objects come in handy?" The most useful cases I've found for employing them are when I've written programs that provide parameter or input criteria for processes, where the range of possible values to search on remain fairly constant from one run of the program to the next.

For instance, in my line of work, almost all of my programs are typically front-ends to very complex query operations. However, the range of domains and their values don't change very often, and from client to client, the same questions are typically asked. So in these cases, I've found that simply streaming my criteria objects (these are all list objects) out to disk when I close the forms and streaming them back in when I open the forms provides a much cleaner solution to saving my criteria sets from session to session. Besides, this is very low overhead programming, since once the programs are finished with the streams, they're immediately destroyed. Not only that, I don't have to use DB.PAS or DBTables.PAS for data operations.

A simple example

The example I've provided here is by no means a full-fledged search program of the type I normally write. I've merely taken the parts pertinent to this article for your use. Feel free to include or modify this code to your heart's content. In any case, here's the code listing for the main form of the program. We'll discuss particulars below.

unit main;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ListBox1DblClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
  begin
    Key := #0;
    ListBox1.Items.Add(Edit1.Text);
    Edit1.Text := '';
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  strm: TFileStream;
begin
  if FileExists('MyList.DAT') then
  begin
    strm := TFileStream.Create('MyList.DAT', fmOpenRead);
    strm.ReadComponent(ListBox1);
    strm.Free;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  strm: TFileStream;
begin
  strm := TFileStream.Create('MyList.DAT', fmCreate);
  strm.WriteComponent(ListBox1);
  strm.Free;
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
  ListBox1.Items.Delete(ListBox1.ItemIndex);
end;

end.

You were expecting some complex code, weren't you? In actuality, this stuff is incredibly simple. So why isn't it documented very well? I'd say it's because this is one of the more uncommon things done in Delphi. But for those of you who wish to really get into the innards of the environment, this stuff is a must to understand and master. Let's look a little deeper into the code.

The program consists of a form with a TEdit and a TListBox dropped onto it. It has just two meaningful methods: FormCreate and FormClose. In the FormCreate method,

procedure TForm1.FormCreate(Sender: TObject);
var
  strm: TFileStream;
begin
  if FileExists('MyList.DAT') then
  begin
    strm := TFileStream.Create('MyList.DAT', fmOpenRead);
    strm.ReadComponent(ListBox1);
    strm.Free;
  end;
end;

the program checks for the existence of MyList.DAT with a call to FileExists, which is the stream file that holds the list box information. If it exists, the file is streamed into ListBox1; otherwise, it does nothing. With the FormClose method,

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  strm: TFileStream;
begin
  strm := TFileStream.Create('MyList.DAT', fmCreate);
  strm.WriteComponent(ListBox1);
  strm.Free;
end;

the program writes ListBox1 out to MyList.DAT, overwriting any previous versions of the file.

That's all there is to this program. Surprisingly, this is one of the more simple things to do in Delphi, but paradoxically it's one of the most difficult things to find good information about in the manuals or help file. Granted, as I mentioned above, doing this type of stuff is fairly uncommon, but think of the implication: simple, low overhead, persistent storage without the need for tables. What was accomplished above was done in fewer than 10 lines of code &#8212; that's absolutely incredible!

I urge you to play around with this technique and apply it to other things. I think you'll get a lot of mileage out of it.

How to hook into Windows' built-in screenshot function

Problem/Question/Abstract:

How to hook into Windows' built-in screenshot function

Answer:

{ ... }
if not fullScreen then
  Keybd_Event(VK_MENU, 0, 0, 0);
Keybd_Event(VK_SNAPSHOT, 0, 0, 0);
Keybd_Event(VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0);
if not fullScreen then
  Keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
{ ... }

The fullScreen value tells, if you wish to get a windowed printscreen or the full screen.

How to remove white-spaces from a string

Problem/Question/Abstract:

I need to be able to search through a list of strings and remove the ones that only contain what I call "white space" - spaces, tabs, control chars, etc.. Is there a function (either Delphi or WinAPI) that will do this?

Answer:

Solve 1:

procedure RemoveBlanks(sl: TStringList);
var
  i, j: Integer;
  blank: Boolean;
  c: Char;
  chars: array[Char] of Boolean;
begin
  { Set all significant chars to false }
  FillChar(chars, SizeOf(chars), True);
  for c := 'A' to 'Z' do
    chars[c] := False;
  for c := 'a' to 'z' do
    chars[c] := False;
  for c := '0' to '9' do
    chars[c] := False;
  i := Pred(sl.Count);
  while (i >= 0) do
  begin
    blank := True;
    j := Length(sl[i]);
    while (blank and (j >= 0)) do
    begin
      blank := blank and chars[sl[i][j]];
      Dec(j);
    end;
    if blank then
      sl.Delete(i);
    Dec(i);
  end;
end;


Solve 2:

procedure DeleteWhiteLines(Strings: TStrings);
var
  I: Integer;
begin
  for I := Strings.Count - 1 downto 0 do
    if TrimLeft(Strings[I]) = '' then
      Strings.Delete(I);
end;


Solve 3:

function KeepStr(sSource: string; ValidChars: TCharSet): string;
var
  iCurPos: Integer;
begin
  Result := Trim(sSource);
  iCurPos := 1;
  if Length(Result) > 0 then
  begin
    repeat
      if Result[iCurPos] in ValidChars then
        Inc(iCurPos)
      else
        Delete(Result, iCurPos, 1);
      if length(Result) = 0 then
        break;
    until (iCurPos = Length(Result) + 1);
  end;
end;

You use KeepStr like this:

type
  TCharSet = set of char;

var
  i: integer;
  s: string;
begin
  {AList is a TStringList declared somewhere}
  {have to work from the end of the list}
  for i := pred(AList) downto 0 do
  begin
    s := AList[i];
    s := KeepStr(s, ['A'..'Z'] + ['a'..'z'] + ['0'..'9']);
    if s = '' then
      AList.Delete(i);
  end;
end;

How to load a menu from a file

Problem/Question/Abstract:

How do I load or recreate a menu stored in a text file? I'm looking for a recursive function.

Answer:

The following seems to work if the data is always organized the way you gave (depth-first recursion).

Level|Name|Caption|
0|miItem1|Item 1|
1|miItem11|Sub Item 1-1|
1|miItem12|Sub Item 1-2|
2|miItem121|Sub sub  Item 1-2-1|
0|miItem2|Item 2|
1|miItem21|Sub Item 2-1|
1|miItem22|Sub Item 2-2|

I found it easier to use a stack instead of recursion, however:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    MainMenu1: TMainMenu;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure MenuClick(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses contnrs;

{$R *.DFM}

function IScan(ch: Char; const S: string; fromPos: Integer): Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := fromPos to Length(S) do
  begin
    if S[i] = ch then
    begin
      Result := i;
      Break;
    end;
  end;
end;

procedure SplitString(const S: string; separator: Char; substrings: TStringList);
var
  i, n: Integer;
begin
  if Assigned(substrings) and (Length(S) > 0) then
  begin
    i := 1;
    repeat
      n := IScan(separator, S, i);
      if n = 0 then
        n := Length(S) + 1;
      substrings.Add(Copy(S, i, n - i));
      i := n + 1;
    until
      i > Length(S);
  end;
end;

procedure LoadMenuFromText(aMenu: TMenu; text: TStrings; aHandler: TNotifyEvent);
type
  TMenuData = record
    level: Integer;
    name: string;
    caption: string
  end;

  procedure SplitLine(const line: string; var data: TMenuData);
  var
    sl: TStringlist;
  begin
    sl := TStringlist.Create;
    try
      SplitString(line, '|', sl);
      Assert(sl.count >= 3);
      data.level := StrToInt(sl[0]);
      data.name := sl[1];
      data.caption := sl[2];
    finally
      sl.free
    end;
  end;

var
  itemStack: TStack;
  level: Integer;
  i: Integer;
  menudata: TMenuData;
  newitem: TMenuItem;
begin
  level := 0;
  itemstack := TStack.Create;
  try
    itemstack.Push(aMenu.Items);
    {skip header line}
    for i := 1 to text.count - 1 do
    begin
      SplitLine(text[i], menudata);
      newitem := Menus.NewItem(menudata.caption, 0, false, true, aHandler, 0,
        menudata.name);
      while level > menudata.level do
      begin
        itemstack.Pop;
        Dec(level);
      end;
      TMenuItem(itemstack.Peek).Add(newitem);
      Itemstack.Push(newitem);
      Inc(level)
    end;
  finally
    itemstack.free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  LoadMenuFromText(mainmenu1, memo1.lines, MenuClick);
end;

procedure TForm1.MenuClick(Sender: TObject);
begin
  label1.caption := (Sender as TMenuItem).Name;
end;

end.

Function to Determine Oracle Version Number

Problem/Question/Abstract:

Function to Determine Oracle Version Number

Answer:

This function gets the connected Oracle version. It returns the version info in 3 OUT parameters.

        VerNum                        : double         eg. 7.23
        VerStrShort         : string                 eg. '7.2.3.0.0'
        VerStrLong         : string                 eg. 'Oracle7 Server Release 7.2.3.0.0 - Production Release'

I have tested it with Oracle 7.2 and 8.17. I assume it should work for the others (not too sure about Oracle 9 though). Any feedback and fixes for different versions would be appreciated.

The TQuery parameter that it recieves is a TQuery component that is connected to an open database connection.

Example :

var
  VNum: double;
  VShort: string;
  VLong: string;
begin
  GetOraVersion(MySql, VNum, VShort, VLong);
  Label1.Caption := FloatToStr(VNum);
  Label2.Caption := VShort;
  Label3.Caption := VLong;
end;

procedure GetOraVersion(Query: TQuery;
                                                                                          out VerNum: double;
                                                                                          out VerStrShort: string;
                                                                                          out VerStrLong: string);
var
  sTmp: string;
  cKey: char;
  i: integer;
begin
  Query.SQL.Text := 'select banner from v$version ' +
                                                                     'where banner like ' + QuotedStr('Oracle%');
  Query.Open;

  if not Query.Eof then
    VerStrLong := Query.Fields[0].AsString
  else
  begin
    // Don't know this version
    VerStrLong := '?';
    VerNum := 0.0;
    VerStrShort := '?.?.?.?';
  end;

  Query.Close;

  if VerStrLong <> '?' then
  begin
    cKey := VerStrLong[7]; // eg. Oracle7 or Oracle8i
    VerStrLong[7] := 'X'; // Mask it out
    sTmp := copy(VerStrLong, pos(cKey, VerStrLong), 1024);
    VerStrShort := copy(sTmp, 1, pos(' ', sTmp) - 1);
    sTmp := copy(VerStrShort, 1, pos('.', VerStrShort));

    for i := length(sTmp) + 1 to length(VerStrShort) do
    begin
      if VerStrShort[i] <> '.' then
        sTmp := sTmp + VerStrShort[i];
    end;

    VerNum := StrToFloat(sTmp);
    VerStrLong[7] := cKey; // Put correct character back
  end;
end;

How to get the text width and height in a TRichEdit

Problem/Question/Abstract:

How to get the text width and height in a TRichEdit

Answer:

procedure TForm1.Button3Click(Sender: TObject);
var
  pt: TPoint;
begin
  with RichEdit1 do
  begin
    pt := point(0, 0);
    Perform(messages.EM_POSFROMCHAR, WPARAM(@pt), SelStart);
    label1.caption := Format('(%d, %d)', [pt.x, pt.y]);
  end;
end;

How to search for a string using the Soundex algorithm

Problem/Question/Abstract:

How to search for a string using the Soundex algorithm

Answer:

Solve 1:

unit SndxAlgs;

interface

uses
  SysUtils;

function Soundex(in_str: string): string;
function NumericSoundex(in_str: string): Smallint;
function ExtendedSoundex(in_str: string): string;

implementation

{Calculate a normal Soundex encoding.}

function Soundex(in_str: string): string;
var
  no_vowels, coded, out_str: string;
  ch: Char;
  i: Integer;
begin
  {Make upper case and remove leading and trailing spaces.}
  in_str := Trim(UpperCase(in_str));
  {Remove vowels, spaces, H, W, and Y except for the first character.}
  no_vowels := in_str[1];
  for i := 2 to Length(in_str) do
  begin
    ch := in_str[i];
    case ch of
      'A', 'E', 'I', 'O', 'U', ' ', 'H', 'W', 'Y':
        ; {Do nothing.}
    else
      no_vowels := no_vowels + ch;
    end;
  end;
  {Encode the characters.}
  for i := 1 to Length(no_vowels) do
  begin
    ch := no_vowels[i];
    case ch of
      'B', 'F', 'P', 'V': ch := '1';
      'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z': ch := '2';
      'D', 'T': ch := '3';
      'L': ch := '4';
      'M', 'N': ch := '5';
      'R': ch := '6';
    else {Vowels, H, W, and Y as the 1st letter.}
      ch := '0';
    end;
    coded := coded + ch;
  end;
  {Use the first letter.}
  out_str := no_vowels[1];
  {Find three non-repeating codes.}
  for i := 2 to Length(no_vowels) do
  begin
    {Look for a non-repeating code.}
    if (coded[i] <> coded[i - 1]) then
    begin
      {This one works.}
      out_str := out_str + coded[i];
      if (Length(out_str) >= 4) then
        Break;
    end;
  end;
  Soundex := out_str;
end;

{Calculate a numeric Soundex encoding.}

function NumericSoundex(in_str: string): Smallint;
var
  value: Integer;
begin
  {Calculate the normal Soundex encoding.}
  in_str := Soundex(in_str);
  {Convert this into a numeric value.}
  value := (Ord(in_str[1]) - Ord('A')) * 1000;
  if (Length(in_str) > 1) then
    value := value + StrToInt(Copy(in_str, 2, Length(in_str) - 1));
  NumericSoundex := value;
end;

{Calculate an extended Soundex encoding.}

function ExtendedSoundex(in_str: string): string;

{Replace instances of fr_str with to_str in str.}
  procedure ReplaceString(var str: string; fr_str, to_str: string);
  var
    fr_len, i: Integer;
  begin
    fr_len := Length(fr_str);
    i := Pos(fr_str, str);
    while (i > 0) do
    begin
      str := Copy(str, 1, i - 1) + to_str + Copy(str, i + fr_len, Length(str) - i - fr_len + 1);
      i := Pos(fr_str, str);
    end;
  end;

var
  no_vowels: string;
  ch, last_ch: Char;
  i: Integer;
begin
  {Make upper case and remove leading and trailing spaces.}
  in_str := Trim(UpperCase(in_str));
  {Remove internal spaces.}
  ReplaceString(in_str, ' ', '');
  {Convert CHR to CR.}
  ReplaceString(in_str, 'CHR', 'CR');
  {Convert PH to F.}
  ReplaceString(in_str, 'PH', 'F');
  {Convert Z to S.}
  ReplaceString(in_str, 'Z', 'S');
  {Remove vowels and repeats.}
  last_ch := in_str[1]; {The last character used.}
  no_vowels := last_ch;
  for i := 2 to Length(in_str) do
  begin
    ch := in_str[i];
    case ch of
      'A', 'E', 'I', 'O', 'U':
        ; {Do nothing.}
    else
      {Skip it if it's a duplicate.}
      if (ch <> last_ch) then
      begin
        no_vowels := no_vowels + ch;
        last_ch := ch;
      end;
    end;
  end;
  ExtendedSoundex := no_vowels;
end;

end.

Used like this:

unit Sndx;

interface

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

type
  TForm1 = class(TForm)
    InputText: TEdit;
    Label1: TLabel;
    CmdEncode: TButton;
    Label2: TLabel;
    Label3: TLabel;
    Panel1: TPanel;
    SoundexLabel: TLabel;
    Panel2: TPanel;
    NumericLabel: TLabel;
    Label4: TLabel;
    Panel3: TPanel;
    ExtendedLabel: TLabel;
    procedure CmdEncodeClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CmdEncodeClick(Sender: TObject);
begin
  SoundexLabel.Caption := Soundex(InputText.Text);
  NumericLabel.Caption := Format('%d', [NumericSoundex(InputText.Text)]);
  ExtendedLabel.Caption := ExtendedSoundex(InputText.Text);
end;

end.


Solve 2:

The code below is designed for use in English language and does not work for special characters like French accents or German Umlauts

function StrSoundEx(const OrgString: string): string;
var
  s: string;
  PrevCh: Char;
  Ch: Char;
  i: Integer;
begin
  s := UpperCase(Trim(OrgString));
  if s <> '' then
  begin
    PrevCh := #0;
    result := s[1];
    for i := 2 to Length(s) do
    begin
      if Length(result) = 4 then
        break;
      Ch := s[i];
      if (Ch <> PrevCh) then
      begin
        if Ch in ['B', 'P', 'F', 'V'] then
          result := result + '1'
        else if Ch in ['C', 'S', 'K', 'G', 'J', 'Q', 'X', 'Z'] then
          result := result + '2'
        else if Ch in ['D', 'T'] then
          result := result + '3'
        else if Ch in ['L'] then
          result := result + '4'
        else if Ch in ['M', 'N'] then
          result := result + '5'
        else if Ch in ['R'] then
          result := result + '6';
        PrevCh := Ch;
      end;
    end;
  end;
  while Length(result) < 4 do
    result := result + '0';
end;


Solve 3:

The following differs from the standard Russell Soundex algorithm in that it lets you set the size of the Soundex code to something other than four characters:

{Given a string this fuction returns the Russell Soundex code for that string. Although the Russell Soundex code is limited to four characters this function allows you to get a code up to 16 characters in length. For names a six to eight character code reduces the number of false matches significantly.

Parameters:
TheWord: The string to be encoded.
SoundexSize: The number of characters in the returned code.

Returns: The Soundex code.}

function dgGetSoundexCode(TheWord: string; SoundexSize: Integer): string;
const
  MaxSize = 16;
var
  I: Integer;
  WorkString1, WorkString2: string;
begin
  {Raise an exception if the SoundexSize parameter is not in the allowed range}
  if not SoundexSize in [1..MaxSize] then
    raise Exception.Create('Soundex size must in the range 1 - 16.');
  {Convert the word to upper case}
  TheWord := UpperCase(TheWord);
  {Copy the first letter}
  WorkString1 := TheWord[1];
  {Copy the rest of the word to WordString1 deleting duplicate letters}
  for I := 2 to Length(TheWord) do
    if TheWord[I - 1] <> TheWord[I] then
      AppendStr(WorkString1, TheWord[I]);
  {Move the first letter to WorkString2}
  WorkString2 := WorkString1[1];
  {Compute the Soundex codes for the remaining letters}
  for I := 2 to Length(WorkString1) do
    case WorkString1[I] of
      'B', 'F', 'P', 'V':
        AppendStr(WorkString2, '1');
      'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z':
        Appendstr(WorkString2, '2');
      'D', 'T':
        Appendstr(WorkString2, '3');
      'L':
        Appendstr(WorkString2, '4');
      'M', 'N':
        Appendstr(WorkString2, '5');
      'R':
        Appendstr(WorkString2, '6');
    end;
  {Pad the string with zeros}
  WorkString1 := '';
  WorkString1 := dgFillString('0', MaxSize);
  AppendStr(WorkString2, WorkString1);
  Result := Copy(WorkString2, 1, SoundexSize);
end;

How to run the Netscape Navigator automatically after closing a form

Problem/Question/Abstract:

How to run the Netscape Navigator automatically after closing a form

Answer:

Do you definitely want to start Netscape, or just the user's default browser? To start Netscape, in preference to anything else, something like this would work in the form's onclose handler (add registry and ShellAPI to your unit's uses list):


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  reg: TRegistry;
  NetscapeVer, NetscapeDir: string;
begin
  {This has a number of shortcomings, not least the lame error handlers}
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if not reg.OpenKey('SOFTWARE\Netscape\Netscape Navigator', false) then
      exit;
    NetscapeVer := reg.ReadString('CurrentVersion');
    if not reg.OpenKey(NetscapeVer + '\Main', false) then
      exit;
    showmessage(reg.CurrentPath);
    NetscapeDir := reg.ReadString('Install Directory') + '\program\';
    ShellExecute(0, 'open', PChar(NetscapeDir + 'netscape.exe'), nil, nil, SW_NORMAL);
  finally
    reg.free;
  end;
end;


If you just wish to start the users browser you could do something like (having added ShellAPI
to your uses list):


ShellExecute(0, 'open', 'http://www.yahoo.com', nil, nil, SW_NORMAL);

How to know if loading is completed when a document contains an iFrame

Problem/Question/Abstract:

If I open a document using .Navigate(URL) this document is loaded. Now, OnDocumentComplete would normally tell me when its done loading, however this document contains an iframe, and in that case the OnDocumentComplete is already fired when the first document is complete.

Answer:

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  CurWebrowser: IWebBrowser;
  TopWebBrowser: IWebBrowser;
  Document: OleVariant;
  WindowName: string;
begin
  CurWebrowser := pDisp as IWebBrowser;
  TopWebBrowser := (Sender as TWebBrowser).DefaultInterface;
  if CurWebrowser = TopWebBrowser then
    ShowMessage('Complete document was loaded')
  else
  begin
    Document := CurWebrowser.Document;
    WindowName := Document.ParentWindow.Name;
    ShowMessage(Format('Frame "%s" was loaded', [WindowName]));
  end;
end;

How to restore / set focus to an application after re-running the executable

Problem/Question/Abstract:

I'm trying to restore/ set focus to my app after re-running the exe. I've tried using the Windows.Setfocus(FormHandle) command without success. I've also tried using ShowWindow. Doing this doesn't set focus to the window. If the the window is minimizied it restores it to the screen ok but the application still believes it is minimized, thus you can't minimize the window. You can overcome this by first right clicking the app's taskbar button and selecting restore. The minimize button then works correctly.

Answer:

You have to deal with the first instances Application window, not with the main form.

{$R *.RES}

function AlreadyRunning: Boolean;
var
  wndmain, wndapp: HWND;
begin
  wndmain := FindWindow('TMDIForm', nil);
  {should really use a more unique classname}
  result := wndmain <> 0;
  if result then
  begin
    wndapp := GetWindowLong(wndmain, GWL_WNDPARENT);
    if IsIconic(wndapp) then
      SendMessage(wndapp, WM_SYSCOMMAND, SC_RESTORE, 0)
    else
      SetForegroundWindow(wndapp);
  end;
end;

begin
  if AlreadyRunning then
    Exit;
  Application.Initialize;
  Application.Title := 'J&S Library Manager';
  Application.CreateForm(TMDIForm, MDIForm);
  Application.CreateForm(TEditTextForm, EditTextForm);
  Application.CreateForm(TOptionForm, OptionForm);
  Application.CreateForm(TAboutBox, AboutBox);
  Application.Run;
end.

I have a deep aversion against directly manipulating a window from outside, so I usually don't restore/show the first instances window from the second instance but instead send a message to the first instances main form and have it restore/show itself in a handler for the message. Using WM_COPYDATA it is also easy to pass on a commandline to the first instance this way.

Traverse the global list of all windows

Problem/Question/Abstract:

Traverse the global list of all windows

Answer:

Sometimes you may want to do something with all windows (and controls) on the screen, including non-Delphi windows.

For such a purpose, you will use the API function EnumWindows. The following code includes the calls MakeProcInstance/ FreeProcInstance, which are needed in 16bit-Windows (including Delphi 1 under Win95).

This sample code hides every existing window.. a rather useless example, but after all, it's just an example.


function NextWindow(Wnd: HWnd; Form: TForm1): Boolean; export;
{$IFDEF Win32} stdcall;
{$ENDIF}
begin
  ShowWindow(Wnd, SW_HIDE);
  NextWindow := true; { next window, please }
end;

procedure TForm1.Sample;
var
  EnumProc: TFarProc;
begin
  { this works in Win32 }
  EnumWindows(@NextWindow, LongInt(Self));

  { MakeProcInstance for Win16 }
  EnumProc := MakeProcInstance(@NextWindow, HInstance);
  EnumWindows(EnumProc, 0);
  FreeProcInstance(EnumProc);
end;

How to calculate the approximate date of birth given the age

Problem/Question/Abstract:

How to calculate the approximate date of birth given the age

Answer:

function TFFuncs.CalcDateFromAge(Age: Integer): TDateTime;
var
  month, day, year, bmonth, bday, byear: word;
  CalcString: string;
begin
  DecodeDate(Date, byear, bmonth, bday);
  byear := byear - Age;
  if (100 * month + day) < (100 * bmonth + bday) then
    byear := byear - 1;
  CalcString := Copy(IntToStr(BMonth), 1, 2) + '/';
  CalcString := CalcString + Copy(IntToStr(BDay), 1, 2) + '/';
  CalcString := CalcString + Copy(IntToStr(BYear), 1, 4);
  Result := StrToDate(CalcString);
end;

Using Anonymous Proxy Servers

Problem/Question/Abstract:

If I am blocked from accessing a website because my ip address is banned, how do I bypass this?

Answer:

If you are writing Internet applications, there may come across a time when your application is blocked from accessing a website. You will get error 403 &#8211; &#8220;your IP address is on a blocked list&#8221;. In my case it happened that we had been given permission to use the data (owned by D) except it was in a website (owned by W).  W didn&#8217;t like us pulling D&#8217;s data even though D had given us permission. The data was extracted every night by a Delphi web application.

For many people this will rarely be a problem because their IP address is allocated dynamically by their ISP. But if yours is static, you need to use an Anonymous Proxy Server. These are ip addresses which you plug into Internet Explorer or HTTP components (such as the ones provided by Winshoes). Anonymous Proxy Servers can be simple Perl scripts that people setup. They can last hours, days or months but do not rely on them. One day they are there- next day- gone. What is important is that the ip address that is logged by the server is the ip of the anonymous proxy, not yours.

You can set the proxy server manually. The code below lets you get the Proxy Server in Ie under Windows Nt 4.0 so that it can be plugged into the HTTPGET component. It has not been tested under Windows 95, 98 or 2000.  ieproxyip is the dotted quad part of the ip address and ieproxyport is the port (usually but not always 80).

References to 10.0.0.2 are the local proxy server. Change these to your own.

procedure GetIEProxy(var ieproxyip: string; var ieproxyport: Integer);
var
  Registry: TRegistry;
  S: string;
  Index: Integer;
  keylist: TStringList;
  KeyName: string;

  procedure GetProxyDetails;
  var
    S, AproxyStr: string;
    Lastfound: Boolean;

    function SkipTo(Marker: string; var Text: string): string;
    var
      P: Integer;
    begin
      Marker := UpperCase(Marker);
      Lastfound := False;
      P := Pos(Marker, UpperCase(Text));
      if P > 0 then
      begin
        result := Copy(Text, P, Length(Text));
        Lastfound := True;
      end
      else
        result := '';
    end;

    function skipforward(N: Integer; ftext: string): string;
    begin
      Result := Copy(ftext, N + 1, 1000);
    end;

    function Skippast(const Marker: string; var Text: string): string;
    var
      tlf: Boolean;
    begin
      Result := SkipTo(Marker, Text);
      tlf := Lastfound;
      if Lastfound then
        Result := skipforward(Length(Marker), Result);
      Lastfound := tlf;
    end;

    function Textupto(const Marker: string; var Text: string): string;
    var
      P: Integer;
    begin
      Result := '';
      Lastfound := False;
      P := Pos(UpperCase(Marker), UpperCase(Text));
      if P > 0 then
      begin
        Result := Copy(Text, 1, P - 1);
        Text := Copy(Text, P, Length(Text));
        Lastfound := True;
      end;
    end;

  begin
    S := Registry.ReadString('ProxyServer');

    if Pos('://', S) > 0 then
    begin
      repeat
        S := Skippast('://', S);
        if Pos(';', S) > 0 then
          AproxyStr := Textupto(';', S)
        else
          AproxyStr := S;
      until not Lastfound or (Pos('10.0.0.2', AproxyStr) = 0);
    end
    else
      AproxyStr := S;

    ieproxyip := '';
    ieproxyport := 80; // Default
    if Index > 0 then
    begin
      Index := Pos(':', AproxyStr); // find port
      if Index = 0 then
        ieproxyip := AproxyStr
      else
      begin
        ieproxyip := trim(Copy(AproxyStr, 1, Index - 1));
        try
          ieproxyport := StrToInt(trim(Copy(AproxyStr, Index + 1, 10)));
        except
        end;
      end;
    end;
  end;

begin
  Registry := TRegistry.Create;
  Registry.Access := Key_read;
  keylist := TStringList.Create;
  Registry.RootKey := HKEY_CURRENT_USER;
  if Registry.OpenKeyReadOnly('Software\Microsoft\Protected Storage System Provider')
    then
  begin
    Registry.GetKeyNames(keylist);
    S := keylist[0];
  end
  else
    Exit;
  KeyName := S;
  Registry.RootKey := HKEY_USERS;

  if Registry.OpenKey(KeyName, False) then
    if Registry.HasSubkeys then
    begin
      KeyName := 'Software\Microsoft\Windows\CurrentVersion\Internet Settings';
      if Registry.OpenKey(KeyName, False) then
      begin
        GetProxyDetails;
      end;
    end;
  Registry.Free;
end;

A good source of proxy server addresses is www.deny.de

Create menus from directory tree (advanced)

Problem/Question/Abstract:

The enhanced version of my CreateTreeMenus

Answer:

You nedd to create only a ImageList and a Menu.

procedure TfrmMain.CreateTreeMenus(Path: string; Root: TMenuItem; ListImage:
  TImageList);
type
  pHIcon = ^HIcon;
var
  SR: TSearchRec;
  Result: Integer;
  Item: TMenuItem;
  SmallIcon: HIcon;
  IconA: TIcon;
  BitMapA: TBitMap;
  Indice: Integer;
  procedure GetAssociatedIcon(FileName: TFilename; pLargeIcon, PSmallIcon: pHIcon);
  var
    IconIndex: Word;
    FileExt: string;
    FileType: string;
    Reg: TRegistry;
    p: Integer;
    p1: pChar;
    p2: pChar;
    function GetSystemDir: TFileName;
    var
      SysDir: array[0..MAX_PATH - 1] of Char;
    begin
      SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
      if (Result = '') then
        raise Exception.Create(SysErrorMessage(GetLastError));
    end;
  label
    NoAssoc;
  begin
    IconIndex := 0;
    FileExt := UpperCase(ExtractFileExt(FileName));
    if (((FileExt <> '.EXE') and (FileExt <> '.ICO')) or (not (FileExists(FileName))))
      then
    begin
      Reg := nil;
      try
        Reg := TRegistry.Create(KEY_QUERY_VALUE);
        Reg.RootKey := HKEY_CLASSES_ROOT;
        if (FileExt = '.EXE') then
          FileExt := '.COM';
        if (Reg.OpenKeyReadOnly(FileExt)) then
        try
          FileType := Reg.ReadString('');
        finally
          Reg.CloseKey;
        end;
        if ((FileType <> '') and Reg.OpenKeyReadOnly(FileType + '\DefaultIcon')) then
        try
          FileName := Reg.ReadString('');
        finally
          Reg.CloseKey;
        end;
      finally
        Reg.Free;
      end;
      if (FileName = '') then
        goto NoAssoc;
      p1 := PChar(FileName);
      p2 := StrRScan(p1, ',');
      if (p2 <> nil) then
      begin
        p := p2 - p1 + 1;
        IconIndex := StrToInt(Copy(FileName, p + 1, Length(FileName) - p));
        SetLength(FileName, p - 1);
      end;
    end;
    if (ExtractIconEx(PChar(FileName), IconIndex, PLargeIcon^, PSmallIcon^, 1) <> 1)
      then
    begin
      NoAssoc:
      try
        FileName := IncludeTrailingBackslash(GetSystemDir) + 'SHELL32.DLL';
      except
        FileName := 'C:\WINDOWS\SYSTEM\SHELL32.DLL';
      end;
      if (FileExt = '.DOC') then
        IconIndex := 1
      else if ((FileExt = '.EXE') or (FileExt = '.COM')) then
        IconIndex := 2
      else if (FileExt = '.HLP') then
        IconIndex := 23
      else if ((FileExt = '.INI') or (FileExt = '.INF')) then
        IconIndex := 63
      else if (FileExt = '.TXT') then
        IconIndex := 64
      else if (FileExt = '.BAT') then
        IconIndex := 65
      else if ((FileExt = '.DLL') or (FileExt = '.SYS') or (FileExt = '.VBX') or
        (FileExt = '.OCX') or (FileExt = '.VXD')) then
        IconIndex := 66
      else if (FileExt = '.FON') then
        IconIndex := 67
      else if (FileExt = '.TTF') then
        IconIndex := 68
      else if (FileExt = '.FOT') then
        IconIndex := 69
      else
        IconIndex := 0;
      if ((ExtractIconEx(PChar(FileName), IconIndex, PLargeIcon^, PSmallIcon^, 1) <>
        1)) then
      begin
        if (PLargeIcon <> nil) then
          PLargeIcon^ := 0;
        if (PSmallIcon <> nil) then
          PSmallIcon^ := 0;
      end;
    end;
  end;
begin
  Path := IncludeTrailingBackSlash(Path);
  Result := FindFirst(Path + '*.*', faDirectory, SR);
  while (Result = 0) do
  begin
    if (((SR.Attr and faDirectory) <> 0) and (SR.Name <> '.') and (SR.Name <> '..'))
      then
    begin
      Item := TMenuItem.Create(Self);
      Item.Caption := SR.Name;
      Item.ImageIndex := 0;
      Root.Add(Item);
      CreateTreeMenus(Path + SR.Name, Item, ListImage);
    end;
    if (((SR.Attr and faAnyFile) <> 0) and (SR.Name <> '.') and (SR.Name <> '..'))
      then
    begin
      Item := TMenuItem.Create(Self);
      Item.Caption := SR.Name;
      GetAssociatedIcon(sr.Name, nil, @SmallIcon);
      IconA := TIcon.Create;
      IconA.Handle := SmallIcon;
      BitMapA := TBitMap.Create;
      BitMapA.Width := IconA.Width;
      BitMapA.Height := IconA.Height;
      BitMapA.Canvas.Draw(0, 0, IconA);
      BitMapA.TransparentMode := tmAuto;
      Indice := ListImage.Add(BitMapA, nil);
      Item.ImageIndex := Indice;
      Root.Add(Item);
    end;
    Result := FindNext(SR);
  end;
  SysUtils.FindClose(SR);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  CreateTreeMenus('c:\projects\', directory1, ImageList1);
end;

You can also use shgetfileinfo with SHGFI_ICON parameter in the place of checking individual file extension.

Undo - Redo using State (update 2)

Problem/Question/Abstract:

Do you need to implement undo and redo in your application?  Here is a simple method, with source, that does the job for small data (up to 20 or 100K in memory)

Answer:

There are 2 methods of Undo-Redo that I know of. The first is saving the current state of the system into a list before it is modified. There would be a GetState and SetState method of your editor.  The second method is to store commands, where each command can undo and redo itself.

Saving state is a good choice when your editor data is small such as 10 to 20K and your editor has many capabilities. Saving state is a simple solution. If you are doing image editing then you could get by with using a file to store your undo and redo information. A vector graphics editor would be a good choice here because vectors do not need much storage space.

The more complex solution of storing commands requires much more coding but is nessesary when your editor edits large amounts of data and storing its state would be too time consuming. A word processor is an example.

I have coded an Undo-Redo State class.. here is how it works. There is the main class that holds the state snapshots (TUndoRedoState), then there is the interface "IState" that has 2 methods, GetState and SetState. I implemented this by making my editor form implement the IState interface.

The main class is created and passed the IState interface. Calling Undo and Redo makes calls to GetState and SetState. If you do not like the way I use an interface then you can easily change the class to accept method pointers to some GetState and SetState method, but I prefer the Interface.

{
  Author William Egge, egge@eggcentric.com
         http://www.eggcentric.com

  Download this working example at http://www.eggcentric.com/UndoRedoState.htm

  This is a demo of using TUndoRedoState.
  Created June 13, 2001

  Enjoy!
}
unit Frm_UndoRedoExample;

interface

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

type
  // Make this form implement the IState interface to be used
  // by the UndoRedoState object.
  TForm_UndoRedoExample = class(TForm, IState)
    FDrawSurface: TImage;
    FRedoBtn: TSpeedButton;
    FUndoBtn: TSpeedButton;
    FDirections: TLabel;
    procedure Ev_FormCreate(Sender: TObject);
    procedure Ev_FUndoBtnClick(Sender: TObject);
    procedure Ev_FRedoBtnClick(Sender: TObject);
    procedure Ev_FDrawSurfaceMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Ev_FDrawSurfaceMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Ev_FDrawSurfaceMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Ev_FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FUndoRedo: TUndoRedoState;
    FMouseDown: Boolean;
  public
    { Public declarations }
    // Methods that implement the IState interface
    procedure GetState(S: TStream);
    procedure SetState(S: TStream);
  end;

var
  Form_UndoRedoExample: TForm_UndoRedoExample;

implementation

{$R *.DFM}

procedure TForm_UndoRedoExample.GetState(S: TStream);
begin
  FDrawSurface.Picture.Bitmap.SaveToStream(S);
end;

procedure TForm_UndoRedoExample.SetState(S: TStream);
begin
  FDrawSurface.Picture.Bitmap.LoadFromStream(S);
end;

procedure TForm_UndoRedoExample.Ev_FormCreate(Sender: TObject);
begin
  // Create a bitmap to draw on
  with FDrawSurface.Picture.Bitmap do
  begin
    Width := FDrawSurface.Width;
    Height := FDrawSurface.Height;
  end;

  // Create the UndoRedo object, this form implements the state interface
  FUndoRedo := TUndoRedoState.Create(Self);
end;

procedure TForm_UndoRedoExample.Ev_FUndoBtnClick(Sender: TObject);
begin
  FUndoRedo.Undo;
end;

procedure TForm_UndoRedoExample.Ev_FRedoBtnClick(Sender: TObject);
begin
  FUndoRedo.Redo;
end;

procedure TForm_UndoRedoExample.Ev_FDrawSurfaceMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  // It is possible to get 2 mouse down events with no mouse up event, but rarely
  // Get out when this happens and let mouse up reset it to false.
  if FMouseDown then
    Exit;

  FMouseDown := True;
  FUndoRedo.BeginModify;

  // Set our start point where you first click
  FDrawSurface.Canvas.MoveTo(X, Y);
end;

procedure TForm_UndoRedoExample.Ev_FDrawSurfaceMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  // Draw
  if FMouseDown then
    FDrawSurface.Canvas.LineTo(X, Y);
end;

procedure TForm_UndoRedoExample.Ev_FDrawSurfaceMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  // Finished Editing
  if FMouseDown then
  begin
    FUndoRedo.EndModify;
    FMouseDown := False;
  end;
end;

procedure TForm_UndoRedoExample.Ev_FormDestroy(Sender: TObject);
begin
  FUndoRedo.Free;
end;

end.

Full Source of UndoRedoState.pas and _State.pas:
2 units:

unit _State;

interface
uses
  Classes;

type
  IState = interface
    procedure GetState(S: TStream);
    procedure SetState(S: TStream);
  end;

implementation

end.

[ver 2, update: fixed problem where setting state the stream needed to be set back to position 0 before calling setState]

unit UndoRedoState;
{
  Author William Egge
         egge@eggcentric.com
         http://www.eggcentric.com
}

interface
uses
  _State, Classes, SysUtils;

// A value of 0 for MaxMemoryUsage means unlimited (default).
type
  TUndoRedoState = class
  private
    FState: IState;
    FUndoRedoList: TList;
    FModifyCount: Integer;
    FUndoPos: Integer;
    FTailState: TStream;
    FMaxMemoryUsage: LongWord;
    FCurrMemUsage: LongWord;
    function CreateCurrentState: TStream;
    procedure SetMaxMemoryUsage(const Value: LongWord);
    procedure TruncToMem;
  public
    constructor Create(AState: IState);
    property MaxMemoryUsage: LongWord read FMaxMemoryUsage write SetMaxMemoryUsage;
    procedure BeginModify;
    procedure EndModify;
    procedure Undo;
    procedure Redo;
    destructor Destroy; override;
  end;

implementation

{ TUndoRedoState }

procedure TUndoRedoState.BeginModify;
var
  I: Integer;
  S: TStream;
begin
  Inc(FModifyCount);
  if FModifyCount = 1 then
  begin
    for I := FUndoRedoList.Count - 1 downto FUndoPos + 1 do
    begin
      S := FUndoRedoList[I];
      Dec(FCurrMemUsage, S.Size);
      FUndoRedoList.Delete(I);
      S.Free;
    end;
    S := CreateCurrentState;
    Inc(FCurrMemUsage, S.Size);
    FUndoRedoList.Add(S);
    FUndoPos := FUndoRedoList.Count - 1;
    if FTailState <> nil then
    begin
      Dec(FCurrMemUsage, FTailState.Size);
      FreeAndNil(FTailState);
    end;
    TruncToMem;
  end;
end;

constructor TUndoRedoState.Create(AState: IState);
begin
  Assert(AState <> nil, 'AState should not be nil for '
    + '"TUndoRedoState.Create(AState: IState)"');

  inherited Create;
  FState := AState;
  FUndoRedoList := TList.Create;
  FUndoPos := -1;
end;

function TUndoRedoState.CreateCurrentState: TStream;
begin
  Result := TMemoryStream.Create;
  try
    FState.GetState(Result);
  except
    Result.Free;
    raise;
  end;
end;

destructor TUndoRedoState.Destroy;
var
  I: Integer;
begin
  FState := nil;
  for I := 0 to FUndoRedoList.Count - 1 do
    TObject(FUndoRedoList[I]).Free;

  FTailState.Free;

  inherited Destroy;
end;

procedure TUndoRedoState.EndModify;
begin
  Assert(FModifyCount > 0, 'TUndoRedoState.EndModify: EndModify was called '
    + 'more times than BeginModify');

  Dec(FModifyCount);
end;

procedure TUndoRedoState.Redo;
var
  FRedoPos: Integer;
  S: TStream;
begin
  Assert(FModifyCount = 0, 'TUndoRedoState.Redo: should not be called while '
    + 'modifying');

  if (FUndoRedoList.Count > 0) and (FUndoPos < (FUndoRedoList.Count - 1)) then
  begin
    FRedoPos := FUndoPos + 2;
    if FRedoPos > (FUndoRedoList.Count - 1) then
    begin
      FTailState.Position := 0;
      FState.SetState(FTailState);
      Dec(FCurrMemUsage, FTailState.Size);
      FreeAndNil(FTailState);
    end
    else
    begin
      S := FUndoRedoList[FRedoPos];
      S.Position := 0;
      FState.SetState(S);
    end;
    Inc(FUndoPos);
  end;
end;

procedure TUndoRedoState.SetMaxMemoryUsage(const Value: LongWord);
begin
  FMaxMemoryUsage := Value;
end;

procedure TUndoRedoState.TruncToMem;
var
  S: TStream;
begin
  if (FMaxMemoryUsage > 0) and (FCurrMemUsage > FMaxMemoryUsage) then
  begin
    while (FUndoRedoList.Count > 0) and (FCurrMemUsage > FMaxMemoryUsage) do
    begin
      S := FUndoRedoList[0];
      FUndoRedoList.Delete(0);
      Dec(FCurrMemUsage, S.Size);
      Dec(FUndoPos);
      S.Free;
    end;

    if (FUndoRedoList.Count = 0) and (FCurrMemUsage > FMaxMemoryUsage) then
      if FTailState <> nil then
      begin
        Dec(FCurrMemUsage, FTailState.Size);
        FreeAndNil(FTailState);
      end;
  end;
end;

procedure TUndoRedoState.Undo;
var
  S: TStream;
begin
  Assert(FModifyCount = 0, 'TUndoRedoState.Undo: should not be called while '
    + 'modifying');

  if FUndoPos >= 0 then
  begin
    if FUndoPos = (FUndoRedoList.Count - 1) then
    begin
      FTailState := CreateCurrentState;
      Inc(FCurrMemUsage, FTailState.Size);
    end;
    S := FUndoRedoList[FUndoPos];
    S.Position := 0;
    Dec(FUndoPos);
    FState.SetState(S);
    TruncToMem;
  end;
end;

end.


Component Download: http://www.eggcentric.com/UndoRedoState.zip

Differentiating Between the Two ENTER Keys

Problem/Question/Abstract:

How to find difference between the two ENTER keys?

Answer:

An application may find it useful to differentiate between the user pressing the ENTER key on the standard keyboard and the ENTER key on the numeric keypad. Either action creates a WM_KEYDOWN message and a WM_KEYUP message with wParam set to the virtual key code VK_RETURN. When the application passes these messages to TranslateMessage, the application receives a WM_CHAR message with wParam set to the corresponding ASCII code 13.

To differentiate between the two ENTER keys, test bit 24 of lParam sent with the three messages listed above. Bit 24 is set to 1 if the key is an extended key; otherwise, bit 24 is set to 0 (zero).

Because the keys in the numeric keypad (along with the function keys) are extended keys, pressing ENTER on the numeric keypad results in bit 24 of lParam being set, while pressing the ENTER key on  the standard keyboard results in bit 24 clear.

The following code sample demonstrates differentiating between these two ENTER keys:

procedure TForm1.WMKeyDown(var Message: TWMKeyDown);
begin
  inherited;
  case Message.CharCode of
    VK_RETURN:
      begin // ENTER pressed
        if (Message.KeyData and $1000000 <> 0) then // Test bit 24 of lParam
        begin
          // ENTER on numeric keypad

        end
        else
        begin
          // ENTER on the standard keyboard

        end;
      end;
  end;
end;

Policy Register Administration Class W2000

Problem/Question/Abstract:

There are many registry settings that affect system policy on the local machine. This class encompasses several of them into a single class. Policy registry entries can be changed individually (via properties) or multiple (via EnableStates and DisableStates) methods. You, of course have to have permissions to write to the Registry.

Properties

TaskManagerEnabled    : Enable/Disable W2000 task manager from popping up.

LockComputerEnabled   : Enable/Disable "Lock Computer" button from Ctrl-Alt-Del Dialog Form.

ChangePasswordEnabled : Enable/Disable "Change Password" button from Ctrl-Alt-Del Dialog Form.

LogOffEnabled         : Enable/Disable "Log Off" button from Ctrl-Alt-Del Dialog Form.

ShutDownEnabled       : Enable/Disable "Shut Down" button from Ctrl-Alt-Del Dialog Form.

RegistryToolsEnabed   : Enable/Disable access to Registry Tools such as  REGEDIT.EXE etc.

DispPropertiesEnabled : Enable/Disable Display Properties dialog box.

Methods

EnableStates  : Enable multi states by passing a set of TRegPolicy

DisableStates : Disable multi states by passing a set of  TRegPolicy

Example

var
PolicyAdm: TPolicyAdmin;

begin
PolicyAdm := TPolicyAdmin.Create;
PolicyAdm.TaskManagerEnabled := false;

if PolicyAdm.LogOffEnabled then
label1.Caption := 'True'
else
label1.Caption := 'False';

PolicyAdm.DisableStates([rpTaskManager,
rpShutDown, rpLogOff]);
PolicyAdm.Free;
end.

Answer:

unit MahPolicyControl;
interface

uses Windows, SysUtils, Registry;

// ==========================================================================
// Class TPolicyAdmin : Encapsulate setting of registry for various Win 2000
// system policies.
//
// Mike Heydon 2004
//
// Properties
// ----------
// TaskManagerEnabled    : Enable/Disable W2000 task manager from popping up.
// LockComputerEnabled   : Enable/Disable "Lock Computer" button from
//                         Ctrl-Alt-Del Dialog Form.
// ChangePasswordEnabled : Enable/Disable "Change Password" button from
//                         Ctrl-Alt-Del Dialog Form.
// LogOffEnabled         : Enable/Disable "Log Off" button from
//                         Ctrl-Alt-Del Dialog Form.
// ShutDownEnabled       : Enable/Disable "Shut Down" button from
//                         Ctrl-Alt-Del Dialog Form.
// RegistryToolsEnabed   : Enable/Disable access to Registry Tools such as
//                         REGEDIT.EXE etc.
// DispPropertiesEnabled : Enable/Disable Display Properties dialog box.
//
// Methods
// -------
// EnableStates  : Enable multi states by passing a set of TRegPolicy
// DisableStates : Disable multi states by passing a set of TRegPolicy
//
// ==========================================================================

// ==========================================================================
// NOTES :
// -------
// There are other registry entries that may be set, but I have not had a
// need to implement them yet. Here is a listing if you wish to implement
// any of them.
//
// Hide display appearance tab in display properties
// C_REG_SYSTEM\NoDispAppearancePage
//
// Hide background tab in display properties
// C_REG_SYSTEM\NoDispBackgroundPage
//
// Hide screen-saver settings tab in display properties
// C_REG_SYSTEM\NoDispScrSavPage
//
// Hide display settings tab in display properties
// C_REG_SYSTEM\NoDispSettingsPage
//
// Remove Control Panel and Printers from Settings menu
// C_REG_EXPLORER\NoSetFolders
//
// Remove Taskbar settings from Settings menu
// C_REG_EXPLORER\NoSetTaskbar
//
// Disable context menus for taskbar
// C_REG_EXPLORER\NoTrayContextMenu
//
// Disable explorer's default context menus
// C_REG_EXPLORER\NoViewContextMenu
//
// ==========================================================================

type
// Registry Setting Type and Set
TRegPolicy = (rpTaskManager, rpLockComputer, rpChangePassword, rpLogOff,
rpShutDown, rpRegistryTools, rpDispProperties);
TRegPolicySet = set of TRegPolicy;

// Main Class TPolicyAdmin
TPolicyAdmin = class(TObject)
private
FReg, FKey: string;
FWinReg: TRegistry;
protected
// Internal Routines
procedure _SetRegKeyInfo(ARegPolicy: TRegPolicy);
procedure _SetState(ARegPolicy: TRegPolicy;
AState: boolean);
function _GetState(ARegPolicy: TRegPolicy): boolean;
procedure _DisableStates(ARegPolicySet: TRegPolicySet);
procedure _EnableStates(ARegPolicySet: TRegPolicySet);

// Set Methods
procedure SetTaskManagerEnabled(AValue: boolean);
procedure SetLockComputerEnabled(AValue: boolean);
procedure SetChangePasswordEnabled(AValue: boolean);
procedure SetLogOffEnabled(AValue: boolean);
procedure SetShutDownEnabled(AValue: boolean);
procedure SetRegistryToolsEnabled(AValue: boolean);
procedure SetDispPropertiesEnabled(AValue: boolean);

// Get Methods
function GetTaskManagerEnabled: boolean;
function GetLockComputerEnabled: boolean;
function GetChangePasswordEnabled: boolean;
function GetLogOffEnabled: boolean;
function GetShutDownEnabled: boolean;
function GetRegistryToolsEnabled: boolean;
function GetDispPropertiesEnabled: boolean;
public
constructor Create;
destructor Destroy; override;

// Methods
procedure DisableStates(ARegPolicySet: TRegPolicySet);
procedure EnableStates(ARegPolicySet: TRegPolicySet);

// Properties
property TaskManagerEnabled: boolean read GetTaskManagerEnabled
write SetTaskManagerEnabled;
property LockComputerEnabled: boolean read GetLockComputerEnabled
write SetLockComputerEnabled;
property ChangePasswordEnabled: boolean read GetChangePasswordEnabled
write SetChangePasswordEnabled;
property LogOffEnabled: boolean read GetLogOffEnabled
write SetLogOffEnabled;
property ShutDownEnabled: boolean read GetShutDownEnabled
write SetShutDownEnabled;
property RegistryToolsEnabled: boolean read GetRegistryToolsEnabled
write SetRegistryToolsEnabled;
property DispPropertiesEnabled: boolean read GetDispPropertiesEnabled
write SetDispPropertiesEnabled;
end;

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

const
// Registry and Key constants
C_REG_POLICIES = '\Software\Microsoft\Windows\CurrentVersion\Policies';
C_REG_SYSTEM = C_REG_POLICIES + '\System';
C_REG_EXPLORER = C_REG_POLICIES + '\Explorer';
C_KEY_TASKMANAGER = 'DisableTaskMgr';
C_KEY_LOCKCOMPUTER = 'DisableLockWorkstation';
C_KEY_CHANGEPASSWORD = 'DisableChangePassword';
C_KEY_LOGOFF = 'NoLogoff';
C_KEY_SHUTDOWN = 'NoClose';
C_KEY_REGISTRYTOOLS = 'DisableRegistryTools';
C_KEY_DISPPROPERTIES = 'NoDispCPL';

// Reverse boolean logic for "ENABLED in proprties"
// to "DISABLED in Registry entries"
C_ENABLE = false;
C_DISABLE = true;

// =================================
// Create and Destroy the Class
// =================================

constructor TPolicyAdmin.Create;
begin
FWinReg := TRegistry.Create;
end;

destructor TPolicyAdmin.Destroy;
begin
FWinReg.Free;

inherited Destroy;
end;

// ====================================================
// Internal Procedures to handle Registry settings
// NOTE : We use ENABLED properties, but the Registry
//        stores the settings as Disabled TRUE/FALSE
//        so we use NOT logic to convert for our use
// ====================================================

// Set Registry key information into Privates

procedure TPolicyAdmin._SetRegKeyInfo(ARegPolicy: TRegPolicy);
begin
case ARegPolicy of
rpTaskManager:
begin
FReg := C_REG_SYSTEM;
FKey := C_KEY_TASKMANAGER;
end;

rpLockComputer:
begin
FReg := C_REG_SYSTEM;
FKey := C_KEY_LOCKCOMPUTER;
end;

rpChangePassword:
begin
FReg := C_REG_SYSTEM;
FKey := C_KEY_CHANGEPASSWORD;
end;

rpLogOff:
begin
FReg := C_REG_EXPLORER;
FKey := C_KEY_LOGOFF;
end;

rpShutDown:
begin
FReg := C_REG_EXPLORER;
FKey := C_KEY_SHUTDOWN;
end;

rpRegistryTools:
begin
FReg := C_REG_SYSTEM;
FKey := C_KEY_REGISTRYTOOLS;
end;

rpDispProperties:
begin
FReg := C_REG_SYSTEM;
FKey := C_KEY_DISPPROPERTIES;
end;
else
raise Exception.Create('Internal TPolicyAdmin Error');
end;
end;

// Read Current Enabled State

function TPolicyAdmin._GetState(ARegPolicy: TRegPolicy): boolean;
var
bResult: boolean;
begin
bResult := true;
_SetRegKeyInfo(ARegPolicy);
FWinReg.RootKey := HKEY_CURRENT_USER;

if FWinReg.OpenKey(FReg, false) then
begin
if FWinReg.ValueExists(FKey) then
bResult := boolean(FWinReg.ReadInteger(FKey))
else
bResult := true;
FWinReg.CloseKey;
end;

// Registry stores state related to "DISABLED", we requiire logic
// related to "ENABLED" - so reverse boolean result
Result := not bResult;
end;

// Set Current State (Using Disabled logic)

procedure TPolicyAdmin._SetState(ARegPolicy: TRegPolicy; AState: boolean);
begin
_SetRegKeyInfo(ARegPolicy);
FWinReg.RootKey := HKEY_CURRENT_USER;

if FWinReg.OpenKey(FReg, true) then
begin
FWinReg.WriteInteger(FKey, integer(AState));
FWinReg.CloseKey;
end;
end;

// Internal enable states from a TRegPolicySet

procedure TPolicyAdmin._EnableStates(ARegPolicySet: TRegPolicySet);
begin
if rpTaskManager in ARegPolicySet then
_SetState(rpTaskManager, C_ENABLE);
if rpLockComputer in ARegPolicySet then
_SetState(rpLockComputer, C_ENABLE);
if rpChangePassword in ARegPolicySet then
_SetState(rpChangePassword, C_ENABLE);
if rpLogOff in ARegPolicySet then
_SetState(rpLogOff, C_ENABLE);
if rpShutDown in ARegPolicySet then
_SetState(rpShutDown, C_ENABLE);
if rpRegistryTools in ARegPolicySet then
_SetState(rpRegistryTools, C_ENABLE);
if rpDispProperties in ARegPolicySet then
_SetState(rpDispProperties, C_ENABLE);
end;

// Internal disable states from a TRegPolicySet

procedure TPolicyAdmin._DisableStates(ARegPolicySet: TRegPolicySet);
begin
if rpTaskManager in ARegPolicySet then
_SetState(rpTaskManager, C_DISABLE);
if rpLockComputer in ARegPolicySet then
_SetState(rpLockComputer, C_DISABLE);
if rpChangePassword in ARegPolicySet then
_SetState(rpChangePassword, C_DISABLE);
if rpLogOff in ARegPolicySet then
_SetState(rpLogOff, C_DISABLE);
if rpShutDown in ARegPolicySet then
_SetState(rpShutDown, C_DISABLE);
if rpRegistryTools in ARegPolicySet then
_SetState(rpRegistryTools, C_DISABLE);
if rpDispProperties in ARegPolicySet then
_SetState(rpDispProperties, C_DISABLE);
end;

// ===============================
// Get/Set Property Methods
// ===============================

// Task Manager

procedure TPolicyAdmin.SetTaskManagerEnabled(AValue: boolean);
begin
if AValue then
_EnableStates([rpTaskManager])
else
_DisableStates([rpTaskManager]);
end;

function TPolicyAdmin.GetTaskManagerEnabled: boolean;
begin
Result := _GetState(rpTaskManager);
end;

// Lock Computer Button

procedure TPolicyAdmin.SetLockComputerEnabled(AValue: boolean);
begin
if AValue then
_EnableStates([rpLockComputer])
else
_DisableStates([rpLockComputer]);
end;

function TPolicyAdmin.GetLockComputerEnabled: boolean;
begin
Result := _GetState(rpLockComputer);
end;

// Change Password Button

procedure TPolicyAdmin.SetChangePasswordEnabled(AValue: boolean);
begin
if AValue then
_EnableStates([rpChangePassword])
else
_DisableStates([rpChangePassword]);
end;

function TPolicyAdmin.GetChangePasswordEnabled: boolean;
begin
Result := _GetState(rpChangePassword);
end;

// Log Off Button

procedure TPolicyAdmin.SetLogOffEnabled(AValue: boolean);
begin
if AValue then
_EnableStates([rpLogOff])
else
_DisableStates([rpLogOff]);
end;

function TPolicyAdmin.GetLogOffEnabled: boolean;
begin
Result := _GetState(rpLogOff);
end;

// Shut Down Button

procedure TPolicyAdmin.SetShutDownEnabled(AValue: boolean);
begin
if AValue then
_EnableStates([rpShutDown])
else
_DisableStates([rpShutDown]);
end;

function TPolicyAdmin.GetShutDownEnabled: boolean;
begin
Result := _GetState(rpShutDown);
end;

// Registry Tools (REGEDIT)

procedure TPolicyAdmin.SetRegistryToolsEnabled(AValue: boolean);
begin
if AValue then
_EnableStates([rpRegistryTools])
else
_DisableStates([rpRegistryTools]);
end;

function TPolicyAdmin.GetRegistryToolsEnabled: boolean;
begin
Result := _GetState(rpRegistryTools);
end;

// Display Properties Dialog

procedure TPolicyAdmin.SetDispPropertiesEnabled(AValue: boolean);
begin
if AValue then
_EnableStates([rpDispProperties])
else
_DisableStates([rpDispproperties]);
end;

function TPolicyAdmin.GetDispPropertiesEnabled: boolean;
begin
Result := _GetState(rpDispProperties);
end;

// ==============================
// User Callabel Methods
// ==============================

procedure TPolicyAdmin.DisableStates(ARegPolicySet: TRegPolicySet);
begin
_DisableStates(ARegPolicySet);
end;

procedure TPolicyAdmin.EnableStates(ARegPolicySet: TRegPolicySet);
begin
_EnableStates(ARegPolicySet);
end;

end.