How to display both Latin and Greek characters in a TRichEdit

Problem/Question/Abstract:

I am trying to display some results in a TRichEdit control. The text is a mixture of Latin letters and Greek (science) letters. Obviously, I have to change the font to 'Symbol' when I want to display the greek letter, otherwise it will be the default font. So, how do I do that? For example how do I display in RichEdit box the following:
RichEdit1.Lines.Add('Standard deviation /* here I want to insert the Greek letter 'sigma' */ is '+FloatToStr(sigma));

Answer:

The key is to not use Lines.Add to add the text, the Lines property is not "formatting-aware". You do it this way:

{ ... }
const
  norm_font = 'Times New Roman';
  norm_charset = DEFAULT_CHARSET;
  symb_font = 'Symbol';
  symb_charset = SYMBOL_CHARSET;
  { ... }

with richedit1 do
begin
  selstart := gettextlen; {set caret to end}
  selattributes.Name := norm_font;
  selattributes.charset := norm_charset;
  seltext := 'Standard deviation ';
  selattributes.Name := symb_font;
  selattributes.charset := symb_charset;
  seltext := 'S';
  selattributes.Name := norm_font;
  selattributes.charset := norm_charset;
  seltext := ' is ' + FloatToStr(sigma);
  { etc. }
end;

As you see this is quite cumbersome but the alternative is even more so: constructing a *complete* rich text file (with font table!) for the text to insert and use EM_STREAMIN to get it into the text.

Making a reliable drawing procedure (No painting, but random numbers!)

Problem/Question/Abstract:

This is very simple, you say: Use a set to store drawn fields!
Yes, you can do if you don't have to many fields to draw. If you pull out more than 255 fields - then the set will say: No more room here! What will you do now?
(And for you who know-how to use arrays to such tasks, don’t read further. I doubt I can tell you any new)

Answer:

I’m not going to make a whole program for you – that’s quite easy, so you manage that yourself.

(Note that the routine is translated from Norwegian – some “funny” names can occur!)

The datatype required:
|
TDrawList = array of ShortString;

We make a dynamic array to make the procedure just that – dynamic. This makes the procedure work just as well with ten records as with ten thousand records. (Not tried – only a theory!) I’m using ShortString, but of course, you can use other datatypes, just remember to change down at the TempDrawList too.

The function-head – the variables: (The name “Draw” was occupied.)

function Drawing(ARecordCount: Integer; ARecords: TDrawList; ADrawCount: Integer):
  TDrawList;

var
  I, Nr: Integer;
  TempDrawList: array of record
    Value: ShortString;
    CanBeDrawn: Boolean;
  end;

ARecordCount: This is the number of records in…
ARecords: This is, as you may understand, all those who CAN be pulled out.
ADrawCount: The number of lucky guys.
I (the variable) are only used in For-statements, while Nr are given a value by the Random function.
TempDrawList: The “set”. This dynamic array knows who’s pulled out and who’s not, stored in the CanBeDrawn field.

The preparations:

SetLength(TempDrawList, ARecordCount);
SetLength(ARecords, ARecordCount);
SetLength(Result, ADrawCount);
for I := 0 to ARecordCount - 1 do // (1 to x = 0 to x-1, and we need to start with 0)
begin
  TempDrawList[I].Value := ARecords[I];
    // Loading the records from the argument to the variable.
  TempDrawList[I].CanBeDrawn := True; // Making sure that all records can be drawn.
end;
Randomize;

First, I allocate place in the memory for the arrays. I do not intend to explain the SetLength procedure. If you need help, consult the Delphi help file.

The next five lines are preparing the TempDrawList for the rest of the procedure, by loading in the records from the argument and setting all “CanBeDrawn”-s to “True”. (The name CanBeDrawn should really be self-explaining!)

At last, I call Randomize. Now the fun begins!

The rest:

for I := 0 to ADrawCount - 1 do // You know what I just wrote: 1 to x = 0 to x-1!
begin
  repeat
    Nr := Random(ARecordCount);
  until TempDrawList[Nr].CanBeDrawn = True;
  Result[I] := TempDrawList[Nr].Value;
  TempDrawList[Nr].CanBeDrawn := False;
end;

To explain step for step:
ADrawCount times do this:
Draw a random number from 0 to AReocordCount, and draw until the CanBeDrawn field in the TempDrawList at [Nr] is True.
Then, put the Value in the TempDrawList[Nr] in Result[I]. Result is a TDrawList, prepared above. “I” is the For counter. (And Nr is a random number, not pulled out before)
The last thing to do is to make sure that it cannot be drawn again.

  TempDrawList[Nr].CanBeDrawn := False.
End;

That’s it. Easy, isn’t it?
(Yes, you’ll say. Easy enough, but… how do I USE this function?)

Using this function:

There are two ways to use it: To make a random list, or to make a random selection from a list:

program UseFunction;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  TDrawList = array of ShortString;

var
  Selection, TheList: TDrawList;
  I: Integer;

function Drawing(ARecordCount: Integer; ARecords: TDrawList; ADrawCount: Integer):
  TDrawList; // The complete function, though without comments.

var
  I, Nr: Integer;
  TempDrawList: array of record
    Value: ShortString;
    CanBeDrawn: Boolean;
  end;

begin
  SetLength(TempDrawList, ARecordCount);
  SetLength(ARecords, ARecordCount);
  SetLength(Result, ADrawCount);
  for I := 0 to ARecordCount - 1 do
  begin
    TempDrawList[I].Value := ARecords[I];
    TempDrawList[I].CanBeDrawn := True;
  end;
  Randomize;
  for I := 0 to ADrawCount - 1 do
  begin
    repeat
      Nr := Random(ARecordCount);
    until TempDrawList[Nr].CanBeDrawn = True;
    Result[I] := TempDrawList[Nr].Value;
    TempDrawList[Nr].CanBeDrawn := False;
  end;
end;

begin
  SetLength(Selection, 3);
  SetLength(TheList, 5);
  for I := 0 to High(TheList) do
    TheList[I] := IntToStr(I);
  Selection := Drawing(Length(TheList), TheList, (Length(Selection));
    for I := 0 to High(Selection) do
      WriteLn(IntToStr(Selection[I]));
    ReadLn;
end.

If you change it to this:

SetLength(Selection, 5);

then the result will be a resorted (?) list.

Delphi FLIC component - a starting point

Problem/Question/Abstract:

Delphi FLIC component - a starting point

Answer:

I have included two files:

aaplay1.inc - an include file with the interface defs for aaplay.dll
aaplay1.pas - a very skeletal flic-playing component
You need a copy of aaplay.dll from Autodesk.

{aaplay1.inc}
{Header file containing constant and type definitions for aaplay1.pas}
const
  NULL = 0;
  NULLPTR = ^0;
  {Valid flags in wMode: integer; Used in aaLoad, aaReLoad. The low order eight bits of wMode is used in aa_flags.}
  AA_MEMORYLOAD = $1; { Load into memory }
  AA_HIDEWINDOW = $2; { Hide the animation window }
  AA_NOPALETTE = $4; { Prevent palette animation }
  AA_RESERVEPALETTE = $8; { Reserve entire palette at start }
  AA_LOOPFRAME = $10; { Loaded with a loop frame }
  AA_FULLSCREEN = $20; { Use full screen for playing }
  AA_STOPNOTIFY = $40; { Prevent any notification messages }
  AA_STOPSTATUS = $80; { Prevent status messages }
  AA_NOFAIL = $100; { Reduce load type on fail }
  AA_DONTPAINT = $200; { Don't paByVal animation when loading }
  AA_BUILDSCRIPT = $400; { lpzFileName is script not name }
  AA_ALLMODES = $FF; {Valid flags for the sound mode - wMode: integer; Used in aaSound}
  AA_SNDFREEZE = $1; { Freeze frames until sound begins }
  AA_SNDDEVICEID = $100; { device is an ID not a name }
  AA_SNDBUILDALIAS = $200; { create sound device alias }
  {aaNotify allows an application to be notified at specific frames when an animation is playing.
lPosition is the position at which the notification is to take place. The wParam for this message is
hAa, and the lParam is copied from this call. Returns TRUE if the notification is set. This value for
the loops will cause the animation to end when the sound has finished. If no sound is playing, the
animation will loop forever.}
  AA_LOOPSOUND = $FFFF;
  {An automatic notify is sent when an animation in a script is reloaded. The lParam
  of this message is defined below}
  AA_ANIMATIONLOADED = 0;
  {The parameter types Used with aaGetParm and aaSetParm.}
  AA_STATUS = 1; { Get current status }
  AA_FILETYPE = 2; { Get Type of animation on disk }
  AA_MODE = 3; { Get/Set Animation Flags }
  AA_WINDOW = 4; { Set/Get animation window }
  AA_SPEED = 5; { Set/Get current speed }
  AA_DESIGNSPEED = 6; { Get design speed }
  AA_FRAMES = 7; { Get Number of frames }
  AA_POSITION = 8; { Set/Get current frame position }
  AA_LOOPS = 9; { Set/Get number of loops }
  AA_X = 10; { Set/Get Pos of display window }
  AA_Y = 11; { Set/Get Pos of display window }
  AA_CX = 12; { Set/Get extents of display window }
  AA_CY = 13; { Set/Get extents of display window }
  AA_ORGX = 14; { Set/Get Origin of display window }
  AA_ORGY = 15; { Set/Get Origin of display window }
  AA_WIDTH = 16; { Get Width of animation }
  AA_HEIGHT = 17; { Get Height of animation }
  AA_RPTSOUND = 18; { Set/Get sound repeats }
  AA_PAUSE = 19; { Set/Get pause time }
  AA_DELAYSND = 20; { Set/Get sound delay time }
  AA_TRANSIN = 21; { Set/Get Transition In type }
  AA_TRANSOUT = 22; { Set/Get Transition Out type }
  AA_TIMEIN = 23; { Set/Get Transition In time }
  AA_TIMEOUT = 24; { Set/Get Transition Out Time }
  AA_CALLBACK = 25; { Set/Get CallBack window }
  AA_ANIMWND = 26; { Get Animation Window Handle }
  AA_MODFLAG = 100; { Set/Get Script is modified flag }
  AA_SCRIPTNAME = 101; { Set/Get Script name }
  AA_ANIMATION = 102; { Get/Set Script Animation }
  AA_ANIMATIONCOUNT = 103; { Get Script Animation Count }
  AA_SCRIPTCONTENTS = 104; { Get Script Contents }
  AA_LASTERROR = 1001; { Get last error code }
  AA_LASTERRORMESSAGE = 1002; { Get/Set last error messsage }
  {The parameter types Used with aaSetParmIndirect}
  AA_SETMODE = $1; { Get/Set Animation Flags }
  AA_SETWINDOW = $2; { Set/Get animation window }
  AA_SETSPEED = $4; { Set/Get current speed }
  AA_SETPOSITION = $8; { Set/Get current frame position }
  AA_SETLOOPS = $10; { Set/Get number of loops }
  AA_SETX = $20; { Set/Get left of display window }
  AA_SETY = $40; { Set/Get left of display window }
  AA_SETCX = $80; { Set/Get top of display window }
  AA_SETCY = $100; { Set/Get top of display window }
  AA_SETORGX = $200; { Set/Get width of display window }
  AA_SETORGY = $400; { Set/Get width of display window }
  AA_SETRPTSOUND = $800; { Set/Get sound repeats }
  AA_SETPAUSE = $1000; { Set/Get pause time }
  AA_SETDELAYSND = $2000; { Set/Get sound delay time }
  AA_SETTRANSIN = $4000; { Set/Get Transition In type }
  AA_SETTRANSOUT = $8000; { Set/Get Transition Out type }
  AA_SETTIMEIN = $10000; { Set/Get Transition In time }
  AA_SETTIMEOUT = $20000; { Set/Get Transition Out Time }
  AA_SETCALLBACK = $40000; { Set/Get Callback window }
  AA_ALL = $FFFFFFFF; { Get/Set all parameters }
  {Status values for an animation}
  AA_STOPPED = 1; { Loaded but not playing }
  AA_QUEUED = 2; { Animation is waiting to play }
  AA_PLAYING = 3; { Animation is playing }
  AA_PAUSED = 4; { Animation is paused }
  AA_DONE = 5; { Animation has ended playing and is awaiting an aaStop call }
  {File type definitions}
  AA_FLI = $1; { Autodesk Animator Fli format }
  AA_DIB = $2; { Windows DIB format }
  AA_NUMTYPES = $2; { Number of types }
  AA_SCRIPT = $3; { Script without an animation }
  {Transition types}
  AA_CUT = 0; { Just stop one and start another }
  AA_FADEBLACK = $1; { Fade In/Out from to black }
  AA_FADEWHITE = $2; { Fade In/Out from to white }
  {Error codes returned by aaGetParm(xxx, AA_LASTERROR)}
  AA_ERR_NOERROR = 0; { Unknown error }
  AA_ERR_NOMEMORY = $100; { 256 - Out of memory error }
  AA_ERR_BADHANDLE = $101; { 257 - Bad handle }
  AA_ERR_NOTIMERS = $102; { 258 - Cannot start timer }
  AA_ERR_BADSOUND = $103; { 259 - Bad sound spec }
  AA_ERR_NOSCRIPT = $104; { 260 - Requires a script }
  AA_ERR_WRITEERR = $105; { 261 - Write error for script }
  AA_ERR_BADANIMATION = $106; { 262 - Cannot open animation }
  AA_ERR_BADWINDOWHANDLE = $200; { 512 - Bad Window Handle }
  AA_ERR_WINDOWCREATE = $201; { 513 - Cannot create window }
  AA_ERR_DLGERROR = $202; { 514 - Dialog error }
  AA_ERR_INVALIDSTATUS = $300; { 768 - Invalid status }
  AA_ERR_BADDIBFORMAT = $301; { 769 - Bad dib file }
  AA_ERR_BADFLIFORMAT = $302; { 770 - Bad fli file }
  AA_ERR_UNRECOGNIZEDFORMAT = $303; { 771 - Unrecognized format }
  AA_ERR_NOSOUND = $304; { 772 - Sound not supported }
  AA_ERR_NOTVALIDFORSCRIPTS = $305; { 773 - Not valid for scripts }
  AA_ERR_INVALIDFILE = $306; { 774 - Bad file handle }
  AA_ERR_NOSCRIPTS = $307; { 775 - No Script files }
  AA_ERR_SPEED = $400; { 1024 - Invalid speed  }
  AA_ERR_LOOPS = $401; { 1025 - invalid loops }
  AA_ERR_RPTSOUND = $402; { 1026 - invalid repeat sound }
  AA_ERR_PAUSE = $403; { 1027 - invalid pause }
  AA_ERR_TRANSIN = $404; { 1028 - invalid transition }
  AA_ERR_TIMEIN = $405; { 1029 - invalid transition }
  AA_ERR_TRANSOUT = $406; { 1030 - invalid transition time }
  AA_ERR_TIMEOUT = $407; { 1031 - invalid transition time }
  AA_ERR_DELAYSND = $408; { 1032 - invalid sound delay }
  AA_ERR_INVALIDTYPE = $409; { 1033 - invalid parameter type }
  AA_ERR_DUPLICATENOTIFY = $500; { 1280 - duplicate notify }
  AA_ERR_NOSWITCH = $600; { 1536 - no switch in script }
  AA_ERR_PARSELOOPS = $601; { 1537 - Bad loops in script }
  AA_ERR_PARSESPEED = $602; { 1538 - Bad speed in script }
  AA_ERR_BADRPTSOUND = $603; { 1539 - Bad repeat sound in script }
  AA_ERR_PARSEPAUSE = $604; { 1540 - Bad pause in script }
  AA_ERR_PARSETRANS = $605; { 1541 - Bad tranisition in script }
  AA_ERR_PARSEDELAYSND = $606; { 1542 - Bad delay sound in script }
  AA_ERR_TOOMANYLINKS = $607; { 1543 - Too many links }
  {dwFlags: integer; can be any of the following Used in aaGetFile.}
  AA_GETFILE_MUSTEXIST = $1;
  AA_GETFILE_NOSHOWSPEC = $2;
  AA_GETFILE_SAVE = $4;
  AA_GETFILE_OPEN = $8;
  AA_GETFILE_USEDIR = $10;
  AA_GETFILE_USEFILE = $20;
  AA_GETFILE_SOUND = $40;
  AA_GETFILE_SCRIPT = $80;
  AA_GETFILE_ANIMATION = $100;
  {wMode: integer; Values Used in aaSave}
  AA_SAVE_IFMODIFIED = $1;
  AA_SAVE_AS = $2;
  AA_SAVE_CANCEL = $4;
  {Capabitlities Used in aaGetCaps}
  AA_CAP_TIMER = 1;
  AA_CAP_SOUND = 2;
  AA_CAP_SCRIPT = 3;
  {Animation status messages Use RegisterWindowMessage to get the real message numbers.}
  AA_NOTIFY = 'AAPLAY Notify'; { notification message }
  AA_STOP = 'AAPLAY Stop'; { stop message }
  {These are sent in the low word of lParam with the AA_ERROR message.
  They indicate the error that occured}
  AA_BADPLAY = 1; { Error attempting to play }
  AA_BADNOTIFY = 2; { Error attempting to notify }
  AA_BADSCRIPT = 3; { Error attempting to animation in script  }

unit aaplay1;

interface

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

{$I AAPLAY1.INC}

const
  AAPARMS_SIZE = 54;

type
  AAHandle = word; { Handle to an animation }
  AASPEED = word; { Type that holds speed for animation }
  AATRN = word; { Type that holds transition for animation }
  dword = longint;
  {The parameter structure to be used for the animation.}
  AAPARMS = record
    AA_STATUS: byte; { Current status of animation }
    AA_FILETYPE: byte; { Type of file on disk }
    AA_MODE: byte; { Some flags }
    AA_bitpix: byte; { bits per pixel }
    AA_HWnd: HWnd; { Handle of window for status messages }
    AA_X: integer; { Left of display window }
    AA_Y: integer; { Top of display window }
    AA_CX: integer; { Width of display window }
    AA_CY: integer; { Height of display window }
    AA_ORGX: integer; { PoByVal in the animation displayed }
    AA_ORGY: integer; { in the upper left corner }
    AA_SPEED: AASPEED; { Speed of animation in msec per frame }
    AA_DESIGNSPEED: AASPEED; { Designed milliseconds per frame }
    AA_WIDTH: word; { Width of animation in pixels }
    AA_HEIGHT: word; { Height of animation in pixels }
    AA_FRAMES: word; { Number of frames in animation }
    AA_POSITION: dword; { Current frame position }
    AA_LOOPS: dword; { End of animation position }
    AA_RPTSOUND: word; { Number of times to repeat sound }
    AA_PAUSE: word; { Number of milliseconds to hold l:t frame }
    AA_DELAYSND: longint; { Delay Sound in milliseconds }
    AA_TRANSIN: byte; { Transition at start of animation }
    AA_TRANSOUT: byte; { Transition at end of animation }
    AA_TIMEIN: word; { Length of transition in, milliseconds }
    AA_TIMEOUT: word; { Length of transition out, milliseconds }
    AA_CALLBACK: HWnd; { message callback window }
    AA_ANIMWND: Hwnd; { Animation Window Handle }
  end;
  AAPARMSPtr = ^AAPARMS;

type
  TAAPlayer = class(TMediaPlayer)
    procedure OpenAA;
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    AAParameters: AAPARMS;
    FlicHandle: AAHandle;
    PlayWinHandle: THandle;
    StatusWinHandle: THandle;
    CallbackWinHandle: THandle;
  published
    { Published declarations }
  end;

procedure Register;

{ External calls to AAPLAY.DLL }
function aaOpen: boolean;
procedure aaClose;
function aaGetCaps(wType: word): word;
function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word; x, y, wid,
  hght, orgx, orgy: integer): AAHandle;
function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word): boolean;
function aaUnload(hAa: AAHandle): boolean;
function aaPlay(hAa: AAHandle): boolean;
function aaNotify(hAa: AAHandle; lPosition, lParam: longint): boolean;
function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint): word;
function aaStop(hAa: AAHandle): boolean;
function aaPause(hAa: AAHandle): boolean;
function aaPrompt(hAa: AAHandle; lpName: PChar): boolean;
function aaGetParm(hAa: AAHandle; wType: word): longint;
function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word): boolean;
function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint): AAHandle;
function aaSetParmIndirect(hAa: AAHandle; dwType: longint; lpAp: AAPARMSPtr;
  wMask: word): boolean;
function aaShow(hAa: AAHandle; bShow: boolean): boolean;
function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word): boolean;
function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word;
  lpszDriver: PChar; wDrvLen: word): integer;
function aaSave(hAa: AAHandle; wMode: word): integer;

implementation

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

procedure TAAPlayer.OpenAA;
var
  FileSuffix, tempstr: string[12];
  a, b: integer;
begin
  tempstr := ExtractFilename(AAPlayer.Filename);
  a := StrPos(tempstr, '.');
  if (a > 0) then
  begin
    b := a;
    while (b <= StrLen(tmpstr)) do
    begin
      FileSuffix := FileSuffix + StrUpper(tempstr[b]);
      b := b + 1;
    end;
    if ((FileSuffix = '.FLC') or (FileSuffix = '.FLI')) then
    begin
      AutoEnable := False;
      EnabledButtons := [btRecord, btEject];
    end;
  end;
end;

{ External calls to 'AAPLAY.DLL' }
{$F+}

function aaOpen: boolean;
  external 'AAPLAY';

procedure aaClose;
  external 'AAPLAY';
{AAOpen and AAClose are not really needed, except there is a bug in Windows
which prevents Libraries from being freed in the Windows Exit Proc (WEP). So we
use AAClose to free the Libraries when the last task closes the AAPlay DLL.}

function aaGetCaps(wType: word): word;
  external 'AAPLAY';

{Get Capabitities}
function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word;
  x, y, wid, hght, orgx, orgy: integer): AAHandle;
  external 'AAPLAY';
{aaLoad loads an animation. The file name is in lpzFileName and the loading mode is in wMode.}

function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word): boolean;
  external 'AAPLAY';
{aaReLoad will load a new animation file into an old animation handle.
Notifications are lost, but the palette and window are retained.}

function aaUnload(hAa: AAHandle): boolean;
  external 'AAPLAY';
{aaUnload unloads a loaded animation. FALSE is returned if hAa is not the handle
of a loaded animation.}

function aaPlay(hAa: AAHandle): boolean;
  external 'AAPLAY';
{aaPlay plays a loaded animation. TRUE is returned if the animation is not stopped
when aaPlay returns.}

function aaNotify(hAa: AAHandle; lPosition, lParam: longint): boolean;
  external 'AAPLAY';
{aaNotify allows an application to be notified at specific frames when an animation
is playing. lPosition is the position at which the notification is to take place. The
wParam for this message is hAa, and the lParam is copied from this call. Returns
TRUE if the notification is set.}

function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint): word;
  external 'AAPLAY';
{aaCancel allows an application to cancel notifications set by aaNotify. lLoPos and
lHiPos give lower and upper limits on positions. Returns the number of notifications
canceled.}

function aaStop(hAa: AAHandle): boolean;
  external 'AAPLAY';
{aaStop will stop a playing animation. TRUE is returned if the animation is stopped
when aaStop returns.}

function aaPause(hAa: AAHandle): boolean;
  external 'AAPLAY';
{aaPause will pause an animation. TRUE is returned if the animation is paused when
aaPause returns. To resume a paused animation, use aaPlay.}

function aaPrompt(hAa: AAHandle; lpName: PChar): boolean;
  external 'AAPLAY';
{aaPrompt will produce a dialog to prompt for user input. When input is accepted, the
handle is changed to reflect the new parameters. The old handle is not destroyed until
the new handle has been created. aaPrompt returns NULL if the new handle cannot be
created, otherwise the new handle is returned.}

function aaGetParm(hAa: AAHandle; wType: word): longint;
  external 'AAPLAY';
{aaGetParm will return information on an animation. Some of the information can be set
with aaSetParm, and other information is state information maintained by AAPLAY.}

function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word): boolean;
  external 'AAPLAY';
{aaGetParmIndirect returns the same information as aaGetParm, in a structure for easy
access by Visual Basic applications.}

function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint): AAHandle;
  external 'AAPLAY';
{aaSetParm will set information on an animation}

function aaSetParmIndirect(hAa: AAHandle; dwType: longint;
  lpAp: AAPARMSPtr; wMask: word): boolean;
  external 'AAPLAY';
{aaSetParmIndirect will set animation parameters from a structure.}

function aaShow(hAa: AAHandle; bShow: boolean): boolean;
  external 'AAPLAY';
{aaShow will show a single frame of an animation in a window. The mode determines
how the animation is drawn. The window used is set using either aaSetParm or
aaSetParmIndirect. aaShow returns TRUE if the animation was successfully drawn.}

function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word): boolean;
  external 'AAPLAY';
{aaSound will open or close a sound for the animation. The sound is opened if the file
arguement is not null and not blank%, otherwise the sound is closed. If device is null,
the format of the file is used to select an appropriate device.}

function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word;
  lpszDriver: PChar; wDrvLen: word): integer;
  external 'AAPLAY';
{Opens a dialog box querying the user for a file in the standard windows file open box
style. dwFlags determines how the dialog box will appear. It may be the following:
AA_GETFILE_MUSTEXIST
Selected file must satisfy conditions of OpenFile() flags, else dialog beeps.
AA_GETFILE_NOSHOWSPEC
Do not show the search spec in the edit box. Default IS to show the spec.
AA_GETFILE_SAVE
Ok button will show "Save".
AA_GETFILE_OPEN
Ok button will show "Open".
AA_GETFILE_USEFILE
Set the filename to the file in lpszPath
AA_GETFILE_UDEDIR
Change to the directory in lpszPath
AA_GETFILE_SOUND
Get sound file and driver
AA_GETFILE_SCRIPT
Get script file
AA_GETFILE_ANIMATION
Get Animation File (no scripts)

lpszPath is a LPSTR to a string buffer into which the final fully qualified pathname
will be written.
wBufLen is the length of this buffer.
lpszDriver is a LPSTR to a string buffer into which a sound device selection is placed.
wDrvLen is the length of this buffer.
Return value is: 0 if cancel was hit, -1 if OpenFile() failed but AA_GETFILE_MUSTEXIST
was not specified. DOS file handle of selected file, otherwise. This handle is not open when
aaOpenFile returns.}

function aaSave(hAa: AAHandle; wMode: word): integer;
  external 'AAPLAY';
{Save a script}

{$F-}
{ End of external calls to 'AAPLAY.DLL' }
end.

Create the MS Access table in run-time

Problem/Question/Abstract:

How can I create a table in MS Access database from own application?

Answer:

In this tip I want to describe how you can in run-time create a table in MS Access database using DAO.

1. declare the variables:

var
  access, db, td, recordset: Variant;

2. declare the array of consts with data type mappings (between Delphi field types and DAO field types)

  arrMDBTypes: array[TFieldType] of Integer =
({dbText} 10 {ftUnknown},
  {dbText} 10 {ftString},
  {dbInteger} 3 {ftSmallint},
  {dbLong} 4 {ftInteger},
  {dbInteger} 3 {ftWord},
  {dbBoolean} 1 {ftBoolean},
  {dbDouble} 7 {ftFloat},
  {dbCurrency} 5 {ftCurrency},
  {dbDouble} 7 {ftBCD},
  {dbDate} 8 {ftDate},
  {dbDate} 8 {ftTime},
  {dbDate} 8 {ftDateTime},
  {dbLongBinary} 11 {ftBytes},
  {dbLongBinary} 11 {ftVarBytes},
  {dbInteger} 3 {ftAutoInc},
  {dbLongBinary} 11 {ftBlob},
  {dbMemo} 12 {ftMemo},
  {dbLongBinary} 11 {ftGraphic},
  {dbMemo} 12 {ftFmtMemo},
  {dbLongBinary} 11 {ftParadoxOle},
  {dbLongBinary} 11 {ftDBaseOle},
  {dbBinary} 9 {ftTypedBinary},
  {dbText} 10 {ftCursor}
{$IFDEF VER120}
  ,
  {dbText} 10 {ftFixedChar},
  {dbText} 10 {ftWideString},
  {dbBigInt} 16 {ftLargeint},
  {dbText} 10 {ftADT},
  {dbText} 10 {ftArray},
  {dbText} 10 {ftReference},
  {dbText} 10 {ftDataSet}
{$ELSE}
{$IFDEF VER125}
  ,
  {dbText} 10 {ftFixedChar},
  {dbText} 10 {ftWideString},
  {dbBigInt} 16 {ftLargeint},
  {dbText} 10 {ftADT},
  {dbText} 10 {ftArray},
  {dbText} 10 {ftReference},
  {dbText} 10 {ftDataSet}

{$ELSE}
{$IFDEF VER130}
  ,
  {dbText} 10 {ftFixedChar},
  {dbText} 10 {ftWideString},
  {dbBigInt} 16 {ftLargeint},
  {dbText} 10 {ftADT},
  {dbText} 10 {ftArray},
  {dbText} 10 {ftReference},
  {dbText} 10 {ftDataSet},
  {dbLongBinary} 11 {ftOraBlob},
  {dbLongBinary} 11 {ftOraClob},
  {dbText} 10 {ftVariant},
  {dbText} 10 {ftInterface},
  {dbText} 10 {ftIDispatch},
  {dbGUID} 15 {ftGuid}
{$ENDIF}
{$ENDIF}
{$ENDIF}
  );

3. load a DAO:

try
  access := GetActiveOleObject('DAO.DBEngine.35');
except
  access := CreateOleObject('DAO.DBEngine.35');
end;

4. open a database

try
  db := access.OpenDatabase(yourDatabaseName);
except
  exit
end;

5. create a new table in opened database

td := db.CreateTableDef(yourTableName, 0, '', '');

6. add a field descriptions in table

td.Fields.Append(td.CreateField(strFieldName, arrMDBTypes[intDataType], Size));

for example

td.Fields.Append(td.CreateField('ID', arrMDBTypes[intDataType], Size));
td.Fields.Append(td.CreateField('NAME', arrMDBTypes[intDataType], Size));

7. add a table definition in table list

db.TableDefs.Append(td);

8. open the created table in database

recordset := db.OpenTable(yourTableName, 0);

9. append the new record in opened table

recordset.AddNew;

10. change the field values

curField := recordset.Fields[0].Value := 1;
curField := recordset.Fields[1].Value := 'First record';

11. post the new record

recordset.Update(dbUpdateRegular, False);

where

const
  dbUpdateRegular = 1;

12. close a recordset

13. close a database

db.Close;

14. destroy a DAO

access := UnAssigned;

Synchronize the movement of two forms

Problem/Question/Abstract:

How can I reposition a form relative to another form, which is being dragged by the mouse? I am thinking of a kind of movement synchronization. TControl.WMMove is unfortunately declared private.

Answer:

The following is a primitive example, but it should get you started:

unit FollowForm;

interface

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

type
  TFrmFollow = class(TForm)
    BtnValidate: TBitBtn;
    BtnSave: TBitBtn;
    BtnPreview: TBitBtn;
    BtnPrint: TBitBtn;
    BtnExit: TBitBtn;
    BtnHelp: TBitBtn;
    procedure BtnExitClick(Sender: TObject);
  private
    FOldOwnerWindowProc: TWndMethod; {WindowProc for FOwnerForm}
    FOwnerForm: TForm;
    {Window subclassing methods:}
    procedure HookForm;
    procedure UnhookForm;
    procedure WndProcForm(var AMsg: TMessage);
  protected
    procedure CreateWnd;
      override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

var
  FrmFollow: TFrmFollow;

implementation

{$R *.DFM}

resourcestring
  SRGSBadUseOfFF = 'FollowForm can only be owned by another form';

constructor TFrmFollow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if AOwner <> nil then
  begin
    if AOwner is TForm then
      FOwnerForm := TForm(AOwner)
    else
      {Owner is not a form}
      raise Exception.CreateRes(@SRGSBadUseOfFF);
  end;
end;

procedure TFrmFollow.CreateWnd;
begin
  inherited;
  if csDesigning in ComponentState then
    Exit; {Don't need to hook when designing}
  if Enabled and Assigned(FOwnerForm) then
    HookForm; {Hook the main form's Window}
end;

destructor TFrmFollow.Destroy;
begin
  if not (csDesigning in ComponentState) then
    UnhookForm; {Stop interfering ...}
  inherited Destroy;
end;

procedure TFrmFollow.HookForm;
begin
  {Hook the windows procedure of my owner only if I have an owner, the Owner's
  window handle has been created and we are not in design mode.}
  FOldOwnerWindowProc := nil;
  if Assigned(FOwnerForm) and FOwnerForm.HandleAllocated then
  begin
    if not (csDesigning in ComponentState) then
    begin
      FOldOwnerWindowProc := FOwnerForm.WindowProc;
      FOwnerForm.WindowProc := WndProcForm;
    end;
  end;
end;

procedure TFrmFollow.UnhookForm;
begin
  {If we are "hooked" then undo what Hookform did}
  if Assigned(FOldOwnerWindowProc) then
  begin
    if (FOwnerForm <> nil) and (FOwnerForm.HandleAllocated) then
    begin
      FOwnerForm.WindowProc := FOldOwnerWindowProc;
    end;
    FOldOwnerWindowProc := nil;
    FOwnerForm := nil;
  end;
end;

{WndProcForm is our replacement for our WindowProc. We grab any Windows
messages that we need here.}

procedure TFrmFollow.WndProcForm(var AMsg: TMessage);
var
  cmdType: Word;
  xPos: Word;
  yPos: Word;
begin
  if Enabled then
  begin
    case AMsg.Msg of
      WM_MOVE:
        begin
          xPos := FOwnerForm.Left;
          yPos := FOwnerForm.Top;
          Caption := Format('%d:%d', [xPos, yPos]);
          SetBounds(xPos + 12, yPos + 12, Width, Height);
          BringToFront;
        end;
      WM_SIZE, WM_EXITSIZEMOVE:
        begin
          BringToFront;
        end;
      WM_SYSCOMMAND:
        begin
          cmdType := AMsg.WParam and $FFF0;
          case cmdType of
            SC_MAXIMIZE, SC_SIZE:
              begin
                xPos := FOwnerForm.Left;
                yPos := FOwnerForm.Top;
                Caption := Format('%d:%d', [xPos, yPos]);
                SetBounds(xPos, yPos, Width, Height);
                BringToFront;
              end;
          end;
        end;
    end;
  end;
  {Call the default windows procedure}
  FOldOwnerWindowProc(AMsg);
end;

procedure TFrmFollow.BtnExitClick(Sender: TObject);
begin
  Close;
end;

end.

How to determine the TImage graphic type at runtime

Problem/Question/Abstract:

Can someone tell me how I get to know the TImage graphic type at runtime? When I know the graphic type, I can choose different ways to save the image.picture to a blob field.

Answer:

Use RTTI like this:

if (Image.Picture.Graphic <> nil) then
begin
  if (Image.Picture.Graphic is TBitmap) then
    {... it's a bitmap ...}
  else if (Image.Picture.Graphic is TIcon) then
    {... it's an icon ...}
  else if (Image.Picture.Graphic is TMetaFile) then
    {... it's a meta file ...}
  else if (Image.Picture.Graphic is TJPEGImage) then
    {... it's a JPEG ...}
  else {... etc.}
end;

Pack a Paradox or dBase table programatically

Problem/Question/Abstract:

How to pack a Paradox or dBase table programmatically

Answer:

Solve 1:

function dgPackParadoxTable(Tbl: TTable; Db: TDatabase): DBIResult;
{Packs a Paradox table by calling the BDE DbiDoRestructure function. The TTable passed as the first parameter must be closed. The TDatabase passed as the second parameter must be connected.}
var
  TblDesc: CRTblDesc;
begin
  Result := DBIERR_NA;
  FillChar(TblDesc, SizeOf(CRTblDesc), 0);
  StrPCopy(TblDesc.szTblName, Tbl.TableName);
  TblDesc.bPack := True;
  Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil, False);
end;


Solve 2:

If you use the DBGrid and DBNavigator to delete records in a table which has unique fields, you will find that the table grows relentlessly and you can't re-enter the same data without packing the table first.

The following routine will pack and reindex a DBase and Paradox table, taking from a few seconds to a few minutes. Tested with a 650K DBaseIV file. Much quicker after the first call.

Just add the code below to the relevant sections. Call the function with your table's name, then wait while it grinds away. Returns True if the table is packed successfully.

uses
  WinProcs, Classes, SysUtils, StdCtrls, Forms, Controls, DB, DBIProcs, DBITypes,
  DBIErrs, DBTables;

{Add to declarations}

function PackTable(tbl: TTable): Boolean;

{Add to Implementation}
  function PackTable(tbl: TTable): Boolean;

    {Packs a DBaseIV (and Paradox?) table}
  var
    crtd: CRTblDesc;
    db: TDataBase;
  begin
    try
      Screen.Cursor := crHourglass;
      Result := True;
      with tbl do
      begin
        db := DataBase;
        if Active then
          Active := False;
        if not db.Connected then
          db.Connected := True;
        FillChar(crtd, SizeOf(CRTblDesc), 0);
        StrPCopy(crtd.szTblName, TableName);
        crtd.bPack := True;
        if DbiDoRestructure(db.Handle, 1, @crtd, nil, nil, nil, False) <> DBIERR_NONE then
          Result := False;
        Open;
      end;
    except
      on Exception do {any exception}
        Result := False;
    end;
    Screen.Cursor := crDefault;
end;


Solve 3:

Wouldn't it be great for the TTable component to have a method that does this? Just open up a TTable, connected it to a table on disk, call the method, and wham! The table's packed (Hmm.... I just might have to look into that). But short of that, you have to make direct calls to the BDE to accomplish this task. For dBase tables, it's easy. There's a single function called dbiPackTable that'll pack any dBase file. For Paradox files, you have to jump through a couple of hoops first, then call dbiDoRestructure because Paradox tables can only be packed within the context of a table restructure (Note: If you've restructured a table in Paradox or the Database Desktop, you'll notice a checkbox at the bottom of the restructure dialog called "Pack Table").

Below is a simple procedure for packing tables. I took most of the code right out of the online help (yes, there's really good stuff in there if you know where look), and made some alterations. The difference between what I did and what the help file lists is that instead of the formal parameter being a TTable, I require a fully qualified file name (path/name). This allows for greater flexibility - the procedure opens up its own TTable and works on it instead you having to create one yourself. I guess it might all boil down to semantics, but I still like my way better (so there!). Check out the code below:

procedure PackTable(TblName: string);
var
  tbl: TTable;
  cProps: CURProps;
  hDb: hDBIDb;
  TblDesc: CRTblDesc;
begin

  tbl := TTable.Create(nil);
  with tbl do
  begin
    Active := False;
    DatabaseName := ExtractFilePath(TblName);
    TableName := ExtractFileName(TblName);
    Exclusive := True;
    Open;
  end;

  // Added 23/7/2000 to make sure that the current path is the same as the table
  //see note below

  SetCurrentDir(ExtractFilePath(TblName));

  // Make sure the table is open exclusively so we can get the db handle...
  if not tbl.Active then
    raise EDatabaseError.Create('Table must be opened to pack');

  if not tbl.Exclusive then
    raise EDatabaseError.Create('Table must be opened exclusively to pack');

  // Get the table properties to determine table type...
  Check(DbiGetCursorProps(tbl.Handle, cProps));

  // If the table is a Paradox table, you must call DbiDoRestructure...
  if (cProps.szTableType = szPARADOX) then
  begin
    // Blank out the structure...
    FillChar(TblDesc, sizeof(TblDesc), 0);
    // Get the database handle from the table's cursor handle...
    Check(DbiGetObjFromObj(hDBIObj(tbl.Handle), objDATABASE, hDBIObj(hDb)));
    // Put the table name in the table descriptor...
    StrPCopy(TblDesc.szTblName, tbl.TableName);
    // Put the table type in the table descriptor...
    StrPCopy(TblDesc.szTblType, cProps.szTableType);
    // Set the Pack option in the table descriptor to TRUE...
    TblDesc.bPack := True;
    // Close the table so the restructure can complete...
    tbl.Close;
    // Call DbiDoRestructure...
    Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
  end
  else
    {// If the table is a dBASE table, simply call DbiPackTable...} if
      (cProps.szTableType = szDBASE) then
      Check(DbiPackTable(tbl.DBHandle, tbl.Handle, nil, szDBASE, True))
    else
      // Pack only works on Paradox or dBASE; nothing else...
      raise EDatabaseError.Create('You can only pack Paradox or dBase tables!');

  with tbl do
  begin
    if Active then
      Close;
    Free;
  end;
end;

See? Nothing fancy. What you should know is that all operations involving dbiDoRestructure revolve around a table descriptor type CRTblDesc. With this record type, you can set various field values, then execute dbiDoRestructure to make your changes. That's kind of the trick to making BDE calls in general. You typically work with some sort of record structure, then use that structure in one of the calls. I know I'm probably oversimplifying, but that's it in a nutshell. The point? Don't be scared of the BDE. More later!

I encourage you to look at the BDE online help under any dbi- subject. There are lots of code examples that will get you on your way.

NOTE: I received an email from Stewart Nightingale who said "When running PackTable straight after saving something to floppy it became obvious that packing a table must use the current directory for temporary tables and things - the current directory was "a:" and it came up with an error saying "No Disk in Drive a:". I put in the line "SetCurrentDir(ExtractFilePath(TblName));" at the top of the procedure so it would work properly ." I have added this line to the code sample shown above - use it if you wish, leave it out if you do not...........

Create an elliptic form using regions

Problem/Question/Abstract:

How to create an elliptic form using regions

Answer:

Add something like the following to your form's OnCreate event handler:

procedure TForm1.FormCreate(Sender: TObject);
var
  Region: HRGN;
begin
  Region := CreateEllipticRgn(0, 0, 300, 300);
  SetWindowRgn(Handle, Region, True);
end;

How to store additional data in a TListBox along with each item it contains

Problem/Question/Abstract:

In my application I have a TListBox control and I need to store additional data along with each item it contains. The additional data will be an integer variable and a status variable. What is the best way of doing this? Is there some other control I can use?

Answer:

TListBox objects are pointers, but you can cast a 32-bit integer to a pointer and store its value directly. Therefore, if your "integer variable" and "status variable" can be crammed into 32 bits, you can do this:

procedure TForm1.Button1Click(Sender: TObject);
var
  MyInt, MyStatus: smallint;
  Combine: integer;
begin
  MyInt := 1234;
  MyStatus := 5678;
  Combine := MyInt or (MyStatus shl 16);
  with ListBox1.Items do
  begin
    { store the string and data }
    AddObject('Foobar', pointer(Combine));
    { retrieve the data }
    MyInt := integer(Objects[0]) and $FFFF;
    MyStatus := integer(Objects[0]) shr 16;
  end;
end;

How to write a Windows NT Service

Problem/Question/Abstract:

How can I turn a regular Delphi application into a service for a Windows NT4 server?
The meaning for this is that the program should run when the server is rebooted and even when the server is not logged on. So putting the program in startup folder is not enough.

Answer:

With Delphi 5, this has become very simple.
Just go to 'File' -> 'New' -> 'Service Application'.
It will create a regular project source with one main 'form', which is derived from TService.

The TService class encapsulates a Windows NT service in an NT service application. A service is accessed via the Service Control Manager. It is usually started during boot time or manually in the control panel 'Services' applet.

The code will look as shown in the example below and consult the online help about TService. You may want to handle the OnExecute event.

type
  TService1 = class(TService)
  private
    { private declarations }
  public
    function GetServiceController: TServiceController; override;
  end;

How to avoid flicker when moving or sizing a MDI child form

Problem/Question/Abstract:

I have an MDI application with many child forms. Their windowstate property is set to maximized. When a child form is created and shown, the form visibly resizes as it is shown. I would like the child form to open already maximized without the visible resizing. Any ideas?

Answer:

Preventing visible flicker when moving or sizing MDI children directly after their creation:

{ ... }
public
{ Public declarations }

constructor Create(aOwner: TComponent); override;
end;

implementation

{$R *.DFM}

constructor TMDIChild.Create(aOwner: TComponent);
var
  crect: TRect;
  chandle: HWND;
begin
  { Get handle of MDI client window }
  chandle := application.mainform.clienthandle;
  { Block redrawing of this window and its children }
  Lockwindowupdate(chandle);
  { Create this MDI child at default position, it will not be drawn yet
        due to the update block }
  inherited Create(aOwner);
  { Get the client windows rect and center this form in it }
  Windows.GetClientrect(chandle, crect);
  SetBounds((crect.right - width) div 2, (crect.bottom - height) div 2, width,
    height);
  { Release the block, this allows the form to redraw at the new position }
  LockWindowUpdate(0);
end;

Enumerating user tables in an InterBase database

Problem/Question/Abstract:

Enumerating user tables in an InterBase database

Answer:

A list of user tables can be retrieved by querying system table rdb$relations.

The example below shows how to do this - it inserts the table names sorted alphabetically into a ListBox (lbSourceTables).

begin
  ibcSourceList.SQL.Clear;
  ibcSourceList.SQL.Add('select rdb$relation_name from rdb$relations');
  ibcSourceList.SQL.Add('where rdb$system_flag = 0');
  ibcSourceList.SQL.Add('order by rdb$relation_name');
  ibcSourceList.Open;
  while not ibcSourceList.Eof do
  begin
    lbSourceTables.Items.Add(ibcSourceList.Fields[0].AsString);
    ibcSourceList.Next;
  end;
  ibcSourceList.Close;
end;

Determining if there is a disk/diskette/CD in a removable-disk drive

Problem/Question/Abstract:

How can I know if there is a CD in the CD drive?

Answer:

The trick is done by calling the API GetDiskFreeSpace and returning its return value as a boolean. The following function takes the drive letter as a parameter (for example 'A', 'D', etc.) and returns True if there is a disk in the drive, or False if not.

var
  DrivePath: array[0..3] of char = 'A:\';

function IsDiskIn(drive: char): boolean;
var
  d1, d2, d3, d4: longword;
begin
  DrivePath[0] := drive;
  Result := GetDiskFreeSpace(DrivePath, d1, d2, d3, d4);
end;

In the implementation we use an initialized null-terminated string (DrivePath) that contains the root directory of drive A: and we substitute the drive letter with the one passed as parameter before calling GetDiskFreeSpace.

Sample call

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not IsDiskIn('A') then
    ShowMessage('Drive A: Not Ready');
end;

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

Define a border for your TMemo field

Problem/Question/Abstract:

Define a border for your TMemo field

Answer:

The following snippet defines a left border of a width of 20 pixels:

var
  Rect: TRect;
begin
  SendMessage(Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
  Rect.Left := 20;
  SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
  Memo1.Refresh;
end;

Inside Delphi's Classes and Interfaces Part I

Problem/Question/Abstract:

You've probably used classes & interfaces more than once in your delphi programs. Did you ever dtop to think how delphi implements this creatures ?

Answer:

A few words before we start :

First, I want to start this article by saying that all of the knowledge in this paper is derived from viewing the disassembler of Delphi5. Hence everything writen here is valid only for Delphi5 and might change by any upgrade / different version.
Second, inorder to fully understand what is writen in this article, you'll have to dive into some assembler code. I'll explain what the assembler code does, but be prepared, it might get messy.

And now to the real stuff. In delphi a class' instance is a simple pointer. That might seem odd to some people, since you've used instances in delphi many a time, and never had to treat them like pointers. That is correct, but only because boralnd was kind enough to wrap these pointers nicly up.
These pointers actually point to a complicated structor in memory, which we'll try and understand. First we'll look at some simple class' defenition :

TBoo1 = class
  FDataA, FDataB: Integer;
end;

var
  Boo1: TBoo1;
begin
  Boo1 := TBoo1.Create;
end;

Now let's look at what Boo1 points to (Boo1 is a pointer, remember ?) :

(Boo1 points to the following values, each 4 bytes long)
a Pointer to TBoo1's VMT
FDataA
FDataB

Now let's examine a decendant of TBoo1 :

TBoo2 = class(TBoo1)
  FDataC, FDataD: Integer;
end;

var
  Boo2: TBoo2;
begin
  Boo2 := TBoo2.Create;
end;

Boo2 will point to the following values in memory :
a Pointer to TBoo2's VMT
FDataA
FDataB
FDataC
FDataD

Notice that the values that Boo2 points to include some of the values that Boo1 points to. That's very easy to explain - TBoo2 inherites from TBoo1, therefor it must include all of the fields that TBoo1 has.

As a general case, we could state that each class instance points to the following values :

a pointer to the Class' VMT
a list of the Class' parent's fields
a list of the Class' fields

Now it's time to investigate interfaces. Before we can fully understand interfaces we must understand the way delphi makes a method call to a class' instance. What delphi actually does, is call a function with one more parameter than was declared, and that parameter is the instance itself. Let's look at an example :

TMoo = class
  FData: Integer;
  procedure Act(Value: Integer);
end;

procedure TMoo.Act(Value: Integer);
begin
  if FData = Value then
    FData := FData + 1
  else
    FData := Value;
end;

var
  Moo: TMoo;
begin
  Moo := TMoo.Create;
  Moo.Act(15);
end;

How does delphi implement this ? Simple, 'TMoo.Act' is actually compiled into a procedure that accepts two(!) parameters. One is the defined parameter -'Value' of type integer. The other is an instance of class TMoo. Every time delphi calls 'Moo.Act' it does some preprocessing before hand, that is, it passes the instance of TMoo that is making the call. Basically you could say that any call to a method of an object is translated to a regular call to a function / procedure that accepts the object making the call as a parameter.
In the previos example, 'TMoo.Act' is actually compiled to something like this :

procedure TMoo_Act(Self: TMoo; Value: Integer);
begin
  if Self.FData = Value then
    Self.FData := FData + 1
  else
    Self.FData := Value;
end;
  
It's time to go back to interfaces. Consider the following code :

IKoo = interface
  function Calculate(Value: Integer): Double;
end;

function Evaluate(Koo: IKoo; Value: Integer): Double;
begin
  Result := Koo.Calculate(Value);
end;

TKooA = class(TInterfacedObject, IKoo)
  function Calculate(Value: Integer): Double;
end;

TKooB = class(TInterfacedObject, IKoo)
  procedure DoNothing;
  function Calculate(Value: Integer): Double;
end;

Any class that supports IKoo can be passed as a variable to the function 'Evaluate'. When we pass an instance of TKooA to 'Evaluate' we need to call the first method of TKooA, but when we pass an instance of TKooB, we need to call the second method of TKooB ! How will delphi now which function to call at each time ?!

Inorder to understand the answer, we must review what an interface realy is (and how it is implemented in delphi). An interface is simply a list of methods that a class declares that it implements. That is, each method in the interface is implemented in the class. The way deplhi implements this is thus :

Each interface a class supports is actually a list of pointers to methods. Therefor, each time a method call is made to an interface, the interface actually diverts that call to one of it's pointers to method, thus giving the object that realy imlpements it the chance to act. I'll explain that via the 'Koo' example above :

Each time the function 'Evaluate' gets a parameter of type IKoo, it realy gets a list (with 4 items - IKoo inherites from IUnknown) of pointers to methods. If it got an IKoo interface that was implemented by TKooA, then the 4th item in the pointer-to-method list would point to  'TKooA.Calcualte'. Otherwise it would point to 'TKooB.Calcualte'. Therefor, when a call is made to 'IKoo.Calculate' what actually is called is what 'IKoo.Calcualte' points to (either 'TKooA.Calculate' or TKooB.Calculate'). Thus delphi implements interfaces.

And now to how delphi stores interfaces in memory. For each instance of a class that supports 'N' interfaces, we need 'N' different lists of pointer-to-method (for each interface we need a list of pointer-to-method). But these lists are the same in the scope of a single class, therefor inorder to save memory, we only hold 'N' pointers to these lists for each instance (instead of the lists themselves).

Consider the following code :

ILooA = interface
end;

ILooB = interface
end;

TLoo = class(TInterfacedObject, ILooA, ILooB)
  FLooA, FLooB: Integer;
end;

This is how an instance of TLoo would look in memory :

a pointer to TLoo's VMT
FRefcount
IUnknown
FLooA
FLooB
ILooB
ILooA

In general, any class' instance would look like this :

a poitner to the class' VMT
the class' parent's structor (except for the pointer to the VMT)
first data member of the class
.
.
last data member of the class
last interface in the class' interface list
.
.
first interface in the class' interface list

As I said at the begining of this article, inorder to realy grasp the way delphi implements class & interfaces we must look at the assembler code delphi produces.
First we'll learn a bit of assembler inorder to understand to code that will follow. In assembler there is a thing called 'Register'. A register is a place on the CPU that can hold a 32 bit value. On a Pentium CPU there are 8 main registers (EAX, EBX, ECX, EDX, ESI, EDI, EBP, ESP). Most actions that are done in assembler are done on registers. Here are a few commands in assembler :

(Moves the value into the register)
MOV Register, Value

(Moves the value in Register2 into Register1)
Mov Register1, Register2

(Moves the value that Register2 points to into Register1. This is the same as the followin code : 'Register1 := Register2^;')
Mov Register1, [Register2]

(Moves the value that Register2 + Value points to into Register1. The same as :
'Register1 := Pointer(Integer(Register2) + Value)^;')
Mov Register1, [Register2 + Value]
  
Eaxmples :

Mov EAX, 10
MOV EBX, EAX
MOV EAX, [EBX + 6]

EBX will hold the value 10 and EAX will hold the value that is in the address $10.

  Just inorder to make sure that you understood this part, I'll give an example of how delphi assignes a value to an instance's data member.

TGoo = class
  FDataA, FDataB: Integer;
end;

var
  Goo: TGoo;
begin
  Goo := TGoo.Create;
  Goo.FDataA := 5;
  Goo.FDataB := 7;
end;

If you'd open delphi's disassembler you'd see the following code :

//Goo.FDataA := 5;
mov eax, [ebp - $08]
mov[eax + $04], $00000005
//Goo.FDataB := 7;
mov eax, [ebp - $08]
mov[eax + $08], $00000007

Why move the value pointed by 'ebp-$08' ? Simple, that's where the variable Goo is stored. Notice that accessing FDataA is the same as accessing the address at 'eax + $04' and that accessing FDataB is the same as accessing the address at 'eax + $08'. That's because the address 'eax' points to is the pointer to the VMT of TGoo, and (as I mentioned before) the following values in memory are the data members of TGoo.

Let's go back to interfaces. Look at the following code :

IRoo = interface
end;

TRoo = class(TInterfacedObject, IRoo)
end;

var
  Roo: TRoo;
  RooIntf: IRoo;
begin
  Roo := TRoo.Create;
  RooIntf := Roo;
  RooIntf._AddRef;
end;

The following assembler code isn't exactly what delphi produces but it serves the same point :

// RooIntf := Roo;
// eax holds the value returned by TRoo.Create, that is, the variable Roo
// ecx holds the value that should later be assigned to RooIntf
mov ecx, eax
// This is the same as : 'ecx := ecx + $0C';
add ecx, $0C
// RooIntf._AddRef
// Push 'ecx' onto the CPU's stack
push ecx
mov ecx, [ecx]
// 'call' tells the CPU to jump to the address stored as a value in 'ecx'
call ecx

Let's look at the code that 'call ecx' brought us too :

// POP the value we pushed onto the stack into 'ecx'
pop ecx
// Same as : 'ecx := ecx - $0c;
sub ecx, $0C
// Call the method '_AddRef' with 'ecx' as a variable.
call TInterfacedObject._AddRef(ecx)

A Little explaination is due. Why did delphi add '$0C' to 'ecx' ? remember how Roo is stored in memory (a pointer to VMT, FRefCount (Of InterfacedObject), IUnknown (Of TInterfacedObject), IRoo). IRoo is the forth value in the list that 'ecx' points to. Each value is 4 bytes long, so IRoo is 12 (4*4) bytes after 'ecx', and '$0C' is 12 in exadecimel notation. So basically, adding '$0C' to 'ecx' just made 'ecx' point to the right value, that is, point to IRoo of Roo (an instance of TRoo).
  
Why do we push ecx into the stack ? That's cause we'll need to use it later, when calling the real '_AddRef' method. Remeber, 'ecx' is the value pointing to Roo + 12.
After that, we move into 'ecx' the value that 'ecx' pointed to. Remeber when I said that instead of holding the lists of pointer-to-method, delphi stores only the pointers to them (to save memory) ? That's why 'ecx' was actually a pointer, but now it holds the value it pointed to before.

  The next command, is to call the method that 'ecx' holds. Now we'll look at that method. It's very short. The only thing it does is modify the value of 'ecx' (after poping it from the stack) so it is equal to the value of Roo (that is, it points to the variable Roo). Then the method 'TInterfacedObject._AddRef' is called with 'ecx' (Roo) as a parameter. This is the same as when I've writen that delphi actually complies a Class' method into a regualr function / procedure that accepts one extra parameter - the instance of the class.
  What was that good for ? We added a value from a poitner then did this jump around in memory, then subtracted the same value from the pointer and called the function the pointer points too ! why bother ? we could simple call the function without adding and subtracting values !
  
  This is where the power of indirection comes into the game. Notice
that the call to 'RooIntf._AddRef' didn't know that RooIntf was actually of an instance of TRoo. It just called the method that was there to call. The Implementation of this method is where the reassigning of the value of the pointer was made. That is, only the implementation that RooIntf points to (IRoo of TRoo) knew how much was added or substracted from the pointer pushed to the stack. If we had another varaible of type TRoo2, that also implemented IRoo, and we would have made the following assignment 'RooIntf := varaible of type TRoo2', and would call the method 'RooIntf._AddRef' then a different value would be subtracted from the value in the stack. Thus making the method call go to the right place in the TRoo2 class.

How to trap mouse clicks on the Desktop when using a system wide mouse hook

Problem/Question/Abstract:

Does anyone know how to tell (in Delphi code) if I have clicked on the Desktop (not an icon). I have written a system wide mouse hook program but the window handle and the icon handle are the same. How can I tell the difference?

Answer:

I did this by creating a DLL (you can only hook into the desktop via a DLL). The DLL then posts messages to the main application. You need to load the DLL, call Initialize supplying the applications handle (note: StdCall). You then need to assign a custom message handler (application.OnMessage) to listen for the messages posted from the DLL.

Here is the application message handler:

const
  WM_DESKTOPMOUSEMESSAGE = WM_USER + 1;

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
  case Msg of
    WM_DESKTOPMOUSEMESSAGE:
      case Msg.WParam of
        WM_LBUTTONUP: ShowMessage('You clicked on the desktop');
      end;
  end;

procedure TForm1.OnCreate(Sender: TObject);
begin
  Application.OnMessage := AppMessage;
end;


Here is the hook code:


Important note about DLL memory management: ShareMem must be the first unit in your library's USES clause AND your project's (select Project-View Source) USES clause if your DLL exports any procedures or functions that pass strings as parameters or function results. This applies to all strings passed to and from your DLL - even those that are nested in records and classes. ShareMem is the interface unit to the BORLNDMM.DLL shared memory manager, which must be deployed along with your DLL. To avoid using BORLNDMM.DLL, pass string information using PChar or ShortString parameters.

library test;

uses
  SysUtils, Messages, Windows;

{$R *.RES}

const
  WM_DESKTOPMOUSEMESSAGE = WM_USER + 1;

var
  HookHandle: HHook;
  DesktopHandle: HWnd;
  AppHandle: HWnd;

procedure log(logstr: string);
var
  F1: Textfile;
begin
  AssignFile(F1, 'c:\temp.log');
  if FileExists('c:\temp.log') then
    Append(F1)
  else
    Rewrite(F1);
  writeln(F1, logstr);
  CloseFile(F1);
end;

function MouseHook(code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall;
var
  WinDir: array[0..MAX_PATH] of Char;
  f: file of HWnd;
begin
  {This only happens once, we use the file just to get the variable across to the systems memory}
  if AppHandle = 0 then
  begin
    GetWindowsDirectory(Windir, MAX_PATH);
    AssignFile(f, WinDir + '\ah.dat');
    Reset(f);
    Read(f, AppHandle);
    CloseFile(f);
  end;
  PostMessage(AppHandle, WM_DESKTOPMOUSEMESSAGE, wParam, lParam);
  Result := CallNextHookEx(HookHandle, Code, WParam, LParam);
end;

procedure Initialize(ApplicationHandle: HWnd); stdcall;
var
  res, pid: DWORD;
  f: file of HWnd;
  WinDir: array[0..MAX_PATH] of Char;
begin
  {Write the application handle to a file so that it can be read first time round
        by the hook (the hook has its own memory space)}
  Fillchar(windir, sizeOf(WinDir), 0);
  GetWindowsDirectory(Windir, MAX_PATH);
  AssignFile(f, WinDir + '\ah.dat');
  Rewrite(f);
  Write(f, ApplicationHandle);
  CloseFile(f);
  DesktopHandle := FindWindow(nil, 'Program Manager');
  if DesktopHandle = 0 then
    HookHandle := 0
  else
  begin
    AppHandle := ApplicationHandle;
    res := GetWindowThreadProcessID(DesktopHandle, @pid);
    HookHandle := SetWindowsHookEx(WH_MOUSE, @MouseHook, hInstance, res);
  end;
end;

procedure DeInitialize; stdcall;
begin
  if HookHandle <> 0 then
    UnHookWindowsHookEx(HookHandle);
end;

exports
  Initialize,
  DeInitialize;

begin
end.

Adding a Master Password to a Paradox Table

Problem/Question/Abstract:

How do I add a password to a Paradox table using nothing but code?

Answer:

It is said that necessity is the mother of invention. And I've found that saying to ring true time and time again. With respect to the subject at hand, I didn't need to know how to do this until I actually had to do it with a program that I needed to write.

But before I started out, I did the usual thing by asking myself some questions:

Is there a method in an existing component (for our purposes TTable) that can do this? Why reinvent the wheel?
If not, is there any resource available that might be able to do this? Again, why reinvent the wheel?

If the answer to both questions is "No," then I know I have to build the capability myself.

You might be thinking, why did I spend time with the discussion above? Well folks, we live in an object-oriented world; moreover, we live in a world where there are a lot of software developers. Someone, somewhere had to think the along the same lines. So as a rule of thumb, before I make an attempt to write a specialized function or component, I always do research to make sure it hasn't been created elsewhere. That said, let's move on, shall we?

First of all, let's talk about Paradox passwords. Paradox has a hierarchical password system. Each table can have a master password that defines any access to it. In addition a table can have several auxilliary passwords that define table and field rights, limiting access in very specialized ways.

In general, though, I've found that encrypting a table with just a master table is adequate because most of the programs I've created that require data encryption only require "all or nothing" security. Besides, having to cover the ins and outs of auxilliary passwords in Delphi would have created an artilce that was just too long. In any case, let me list the code below that will add a master password to a Paradox table, then we'll discuss particulars following it. Here goes...

procedure EncryptPDOXTable(TableName,
  Password: string);
var
  TblDesc: CRTblDesc;
  LocDB: TDatabase;
begin
  //Initialize the BDE
  Check(DBIInit(nil));

  //Initialize random number generator
  Randomize;

  //Create a local, non-owned database object that
  //points to the path associated with the table.
  LocDB := TDatabase.Create(nil);
  with LocDB do
  begin
    Params.Add('path=' + ExtractFilePath(TableName));
    DatabaseName := 'PDOXEncryptDB' + IntToStr(Random(50));
    DriverName := 'STANDARD';
    Connected := True;
  end;

  //Now, initialize the Table Descriptor with the values
  //required to set a master password.
  FillChar(TblDesc, SizeOf(CRTblDesc), 0);
  StrPCopy(TblDesc.szTblName, ExtractFileName(TableName));
  with TblDesc do
  begin
    bProtected := True;
    StrPCopy(TblDesc.szPassword, Password);
  end;

  //Now do the restructure.
  try
    Check(DbiDoRestructure(LocDB.Handle, 1, @TblDesc,
      nil, nil, nil, False));
  finally
    LocDB.Free;
    DBIExit;
  end;
end;

I think you've figured out by now that to create a master password in a Paradox table, you have to use direct BDE calls. And while it may seem a bit complex, it's actually pretty easy. You'll notice that I put a couple of words in the code in boldface type. These are the two things that you really have to worry about as far as setting a password. The other stuff is pretty routine stuff. So looked at from that perspective simplifies the process entirely. Why don't we discuss the code in a bit more detail.

The first things that I do in the procedure is to initialize the BDE and create a TDatabase object. You'll find that almost all things that you do in the BDE require a database handle of some sort. DbiDoRestructure is no exception. With respect to initializing the BDE, that's purely an option, but something that I've done as a habit primarily because some of my programs don't make use of any data aware components, and thus won't initialize the BDE by default. If you make calls to the BDE without it having been initialized in some way, you'll get an initialization error. So it's a good idea to do this.

The next thing that happens in the code is that I initialize a table descriptor structure. This is a standard structure defined in the BDE that tells BDE functions that use it, like DbiDoRestructure, about the table that they're going to work with. CRTblDesc is a fairly complex structure that has substructures attached to it. If you want to know more about what kinds of fields are in this structure, I suggest looking in the BDE help file in the BDE directory on your hard disk. But the way cool thing about CRTblDesc is that you only need to fill in the fields that are pertinent to the operation you want to perform. In the case of adding a password to a table, all you need to fill in are the szTblName field and szPassword field. That's it.

Then, once the structure has been filled with proper values, it's a simple matter of calling DbiDoRestructure to restructure the table. We supply the handle to the database that was created at the top, the number of table descriptors we're using (1), the address to the table descriptor, then set the next three parameters to "nil" and the last parameter to False. Easy.

If you want to know more about using DbiDoRestructure (since it's obviously used to do many more table operations than what I just discussed) I encourage you to study the online help, or obtain a copy of the "Borland Database Engine Developer's Guide" which you can purchase directly from Borland. Cheers!

Create a (unique) GUID (2)

Problem/Question/Abstract:

I have a very simple piece of test code to generate and display a GUID on the screen every time a user clicks on a button on a form. When I compile the program and run the executable on my Windows 2000 machine, I get a unique GUID every time I click the button, which is what I expect from the documentation. However, when I run the same executable on any Windows 98 SE machine, and even a Windows NT 4.0 Server (with SP5), it simply generates the exact same GUID over, and over, and over again.

Answer:

Using RAW API:

{ ... }
var
  Form1: TForm1;
  UuidCreateFunc: function(var guid: TGUID): HResult; stdcall;

implementation

{$R *.DFM}

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  hr: HRESULT;
  m_TGUID: TGUID;
  handle: THandle;
begin
  handle := LoadLibrary('RPCRT4.DLL');
  @UuidCreateFunc := GetProcAddress(Handle, 'UuidCreate');
  hr := UuidCreateFunc(m_TGUID);
  if failed(hr) then
    RaiseLastWin32Error;
  ShowMessage(GUIDToString(m_TGUID));
end;

With WIN2K support:

{ ... }
var
  Form1: TForm1;
  UuidCreateFunc: function(var guid: TGUID): HResult; stdcall;

implementation

{$R *.DFM}

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  hr: HRESULT;
  m_TGUID: TGUID;
  handle: THandle;
  WinVer: _OSVersionInfoA;
begin
  handle := LoadLibrary('RPCRT4.DLL');
  WinVer.dwOSVersionInfoSize := sizeof(WinVer);
  getversionex(WinVer);
  if WinVer.dwMajorVersion >= 5 then {Windows 2000 }
    @UuidCreateFunc := GetProcAddress(Handle, 'UuidCreateSequential')
  else
    @UuidCreateFunc := GetProcAddress(Handle, 'UuidCreate');
  hr := UuidCreateFunc(m_TGUID);
  if failed(hr) then
    RaiseLastWin32Error;
  ShowMessage(GUIDToString(m_TGUID));
end;

How to store and retrieve a text file in / from a resource

Problem/Question/Abstract:

I am trying to work out how to store approximately 1000 lines of text (3 columns, 30 chars each) inside an application. I do not want to have any .INI entries and would prefer not to use an external file.

Answer:

You can start with one and embed it into a resource. Let's assume you have the data in a normal textfile. Make a resource script file (filedata.rc) with a line like

FILEDATA RCDATA filedata.txt

Add this RC file to your Delphi 5 project group. This automatically gets you a $R line for it in the project DPR file and the resource is compiled for you when you build the project. Now, how to get at the data at runtime? Each line is a fixed length of 90 characters. So the file could be represented as an array of records of this type:

type
  TFileData = packed record
    col1, col2, col3: array[1..30] of Char;
    crlf: array[1..2] of Char;
  end;
  PFileData = ^TFileData;

Let's use a class to regulate access to the data. I assume you only need to read it, so there is no need to copy it from the resource.

type
  TDatahandler = class
  private
    FData: TList;
    FResHandle: THandle;
    function GetRecord(index: Integer): TFileData;
    procedure GetRecordCount: Integer;
    procedure InitDatalist;
  public
    constructor Create;
    destructor Destroy; override;
    property Records[index: Integer]: TFileData read GetRecord;
    property Recordcount: Integer read GetRecordcount;
  end;

implementation

constructor TDatahandler.Create;
begin
  inherited;
  FData := TList.Create;
  InitDatalist;
end;

destructor TDatahandler.Destroy;
begin
  Fdata.Free;
  if FResHandle <> 0 then
  begin
    UnlockResource(FResHandle);
    FreeResource(FResHandle);
  end;
  inherited;
end;

function TDatahandler.GetRecord(index: Integer): TFileData;
begin
  Result := PFileData(FData[i])^;
end;

procedure TDatahandler.GetRecordCount: Integer;
begin
  Result := FData.Count;
end;

procedure TDatahandler.InitDatalist;
var
  dHandle: THandle;
  pData: PFileData;
  numRecords, i: Integer;
begin
  pData := nil;
  dHandle := FindResource(hInstance, 'FILEDATA', RT_RCDATA);
  if dHandle <> 0 then
  begin
    numRecord := SizeofResource(hInstance, dHandle) div Sizeof(TFiledata);
    FResHandle := LoadResource(hInstance, dHandle);
    if FResHandle <> 0 then
    begin
      pData := LockResource(dHandle);
      if pData <> nil then
      begin
        FData.Capacity := NumRecords;
        for i := 1 to Numrecords do
        begin
          FData.Add(pData);
          Inc(pData);
        end;
      end
      else
        raise Exception.Create('Lock failed');
    end
    else
      raise Exception.Create('Load failed');
  end
  else
    raise Exception.Create('Resource not found');
end;

You can add a method to sort the FData list, for example, or a filter method that would populate another TList with pointer to records that match a set of criteria.

How to sort a TCheckListBox without loosing the check state

Problem/Question/Abstract:

How to sort a TCheckListBox without loosing the check state

Answer:

Sorting without loosing the check state is a bit of a challenge, but it can be done. The code below has only been superficially tested:

{ ... }
type
  TItemState = class
  public
    Data: TObject;
    Checked: Boolean;
    constructor Create(aData: TObject; aChecked: Boolean);
  end;

constructor TItemState.Create(aData: TObject; aChecked: Boolean);
begin
  inherited Create;
  Data := aData;
  Checked := aChecked;
end;

procedure CustomSortChecklist(aList: TChecklistbox; Compare: TStringListSortCompare = nil);
var
  sl: TStringlist;
  i: Integer;
  stateobj: TItemState;
begin
  Assert(Assigned(aList), 'CustomSortChecklist: no list to sort.');
  sl := TStringlist.Create;
  try
    sl.Assign(aList.Items);
    for i := 0 to sl.Count - 1 do
      sl.Objects[i] := TItemState.Create(sl.Objects[i], aList.Checked[i]);
    if Assigned(Compare) then
      sl.CustomSort(Compare)
    else
      sl.Sort;
    alist.Items.BeginUpdate;
    try
      aList.Clear;
      for i := 0 to sl.Count - 1 do
      begin
        stateobj := sl.Objects[i] as TItemState;
        aList.Items.AddObject(sl[i], stateobj.Data);
        aList.Checked[i] := stateobj.Checked;
      end;
    finally
      aList.Items.EndUpdate;
    end;
  finally
    for i := 0 to sl.Count - 1 do
      if Assigned(sl.Objects[i]) and (sl.Objects[i] is TItemState) then
        sl.Objects[i].Free;
    sl.free;
  end;
end;

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

function ReverseSort(List: TStringList; Index1, Index2: Integer): Integer;
begin
  result := AnsiCompareText(list[index2], list[index1]);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  CustomSortChecklist(checklistbox1, Reversesort);
end;

Hacking the Help Files

Problem/Question/Abstract:

Hacking the Help Files

Answer:

I often get tired of help files with broken links, topics that are hard to get to and difficult navigation. However, there's a great way you can use the arrow keys (along with SHIFT+CTRL) to navigate through the help files.

To be able to navigate through the help files using CTRL+SHIFT+arrow key (left or right), add the following lines to WIN.INI:

[Windows Help]
Help Author=1

This will enabled "Help Author Mode" on Windows. What it means is that you'll have special privileges on help files, such as:

Topic numbers: Title bar text is replaced by unique topic numbers that identify each topic's position in the Help file.
Easier navigation: You can move to the following or preceding topic by pressing CTRL+SHIFT+RIGHT ARROW or CTRL+SHIFT+LEFT ARROW. To move to the beginning or end of your Help file, press CTRL+SHIFT+HOME or CTRL+SHIFT+END.
Information about topics A Topic Information command appears when you click a topic by using your right mouse button. Clicking this command displays a window with several info reagrding that topic.
Information about hotspots An Ask On Hotspots command appears when you click a topic by using your right mouse button.

This information is documented in the Microsoft Help Workshop 4.0 (HCW.EXE) help file. If you have installed Delphi, you probably have this this tool installed in the Help\MSTools dir under the Delphi installation directory. You'll can also gather lots of information about a help file by using the Report... command on the file menu of Help Workshop.

MS Help Workshop has helped me gather lots of info on other help files, and even find out topics the author probably want to keep as a secret, if that is possible. For example, you can save all the text of a help file to a plain text file, or save a listing of all the topics of a help file to a text file.

"Help Author Mode" can also be enabled by selecting "Help Author" from the File menu of MS Help workshop.

Some useful Windows NT functions

Problem/Question/Abstract:

Some useful Windows NT functions

Answer:

{-----------------------------------------------------------------------------
Unit Name:     unitNTFunctions
Author:        StewartM

Documentation Date: 22 February, 2002 (11:04)

Version 1.0
-----------------------------------------------------------------------------

Purpose:
  To provide a few handy Windows NT API functions.

Description:

  Unit written by Stewart Moss (except where indicated)
  Some of the functions are incomplete or not tested.

Copyright 2001 by Stewart Moss. All rights reserved.
-----------------------------------------------------------------------------}

unit unitNTFunctions;
// Unit written by Stewart Moss (except where indicated)

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

const
  BSECURITY_NULL_SID_AUTHORITY = 0;
  BSECURITY_WORLD_SID_AUTHORITY = 1;
  BSECURITY_LOCAL_SID_AUTHORITY = 2;
  BSECURITY_CREATOR_SID_AUTHORITY = 3;
  BSECURITY_NT_AUTHORITY = 5;

  SECURITY_INTERACTIVE_RID = $00000004;
  SECURITY_BUILTIN_DOMAIN_RID = $00000020;
  DOMAIN_ALIAS_RID_ADMINS = $00000220;

  ACL_REVISION = 2;
  SECURITY_DESCRIPTOR_REVISION = 1;

type
  PACE_Header = ^TACE_Header;
  TACE_Header = record
    AceType: BYTE;
    AceFlags: BYTE;
    AceSize: WORD;
  end;

  PAccess_Allowed_ACE = ^TAccess_Allowed_ACE;
  TAccess_Allowed_ACE = record
    Header: TACE_Header;
    Mask: ACCESS_MASK;
    SidStart: DWORD;
  end;
const
  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority =
  (Value: (0, 0, 0, 0, 0, 5));

function ISHandleAdministrator(UserToken: THandle): Boolean;
function IsAdmin: Boolean;
function ReturnUserHandle(Username: string): THandle;
function IsWinNT: boolean;

function TryToLoginAsUser(Username, Domain, Password: string): THandle;

implementation

function ISHandleAdministrator(UserToken: THandle): Boolean;
// this function written by Stewart Moss
var
  tmpBuffer: array[0..1024] of char;
  BufferPtr: Pointer;
  ptgGroups: PTokenGroups;
  dwInfoBufferSize: DWord;
  PSIDAdministrators: PSID;
  siaNTAuthority: SID_IDENTIFIER_AUTHORITY;
  X: DWord;
  bSuccess: Boolean;

begin
  GetMem(PtgGroups, 1024);

  bSuccess := GetTokenInformation(UserToken, TokenGroups, ptgGroups,
    1024, dwInfoBufferSize);
  result := false;
  if not bsuccess then
    exit;

  if not AllocateAndInitializeSid(siaNtAuthority, 2,
    SECURITY_BUILTIN_DOMAIN_RID,
    DOMAIN_ALIAS_RID_ADMINS,
    0, 0, 0, 0, 0, 0,
    psidAdministrators) then
    exit;

  for x := 0 to ptgGroups.GroupCount do
  begin
    if EqualSID(psidAdministrators, ptgGroups.Groups[x].SID) then
    begin
      result := true;
      break;
    end;
  end;
  freemem(PtgGroups);
  Freemem(PsidAdministrators);
  result := true;
end;

function IsAdmin: Boolean;
// This function written by somebody else
var
  hAccessToken: THandle;
  ptgGroups: PTokenGroups;
  dwInfoBufferSize: DWORD;
  psidAdministrators: PSID;
  x: Integer;
  bSuccess: BOOL;
begin
  Result := False;
  bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,
    hAccessToken);
  if not bSuccess then
  begin
    if GetLastError = ERROR_NO_TOKEN then
      bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
        hAccessToken);
  end;
  if bSuccess then
  begin
    GetMem(ptgGroups, 1024);
    bSuccess := GetTokenInformation(hAccessToken, TokenGroups,
      ptgGroups, 1024, dwInfoBufferSize);
    CloseHandle(hAccessToken);
    if bSuccess then
    begin
      AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
        SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
        0, 0, 0, 0, 0, 0, psidAdministrators);
{$R-}
      for x := 0 to ptgGroups.GroupCount - 1 do
        if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then
        begin
          Result := True;
          Break;
        end;
{$R+}
      FreeSid(psidAdministrators);
    end;
    FreeMem(ptgGroups);
  end;
end;

function ReturnUserHandle(Username: string): THandle;
// Function written by Stewart Moss
begin

end;

function IsWinNT: boolean;
// Function Written by Stewart Moss
var
  osv: TOSVERSIONINFO;
begin
  result := false;
  osv.dwOSVersionInfoSize := sizeOf(OSVERSIONINFO);
  GetVersionEx(osv);
  if (osv.dwPlatformId = VER_PLATFORM_WIN32_NT) then
    result := true;
end;

function TryToLoginAsUser(Username, Domain, Password: string): THandle;
// Function written by Stewart Moss
// returns 0 if failed else User Handle
var
  tmpstr: string;
  hToken: THandle;
begin
  result := 0;

  if (UserName = '') or (Domain = '') then
    exit;

  if not LogonUser(PChar(Username), Pchar(Domain), PChar(Password),
    LOGON32_LOGON_INTERACTIVE,
    LOGON32_PROVIDER_DEFAULT, hToken) then
    exit;
  result := hToken;
end;

(*function ApplySecurityDescriptorToRegistryKey(Key : Hkey): Boolean;
var lRv : longint;
  siaNtAuthority : SID_IDENTIFIER_AUTHORITY;
  psidSystem, psidAdministrators: PSID;
  tmpACL : ACL;
  pNewDACL : PACL;
  dwACL : DWord;
  ACLRevision : ACL_REVISION_INFORMATION;
begin
    siaNtAuthority := SECURITY_NT_AUTHORITY;
    result := false;
    InitializeSid(psidAdministrators, siaNtAuthority,2);
    InitializeSid(psidSystem, siaNtAuthority,1);

    //*(GetSidSubAuthority(psidAdministrators,0)) = SECURITY_BUILTIN_DOMAIN_RID;
    //*(GetSidSubAuthority(psidAdministrators,1)) = DOMAIN_ALIAS_RID_ADMINS;
    //*(GetSidSubAuthority(psidSystem,0)) = SECURITY_LOCAL_SYSTEM_RID;

//    getmem(pNewDACL, sizeof(PACL));
//    pNewDACL := tmpAcl;

    dwAcl := sizeof(PACL);

    if not GETAclInformation(pnewAcl,

    if (not InitializeAcl(pnewDACL,
                       dwACL,
                       ACL_REVISION))  then exit;

    if (!AddAccessAllowedAce(pNewDACL,
                             ACL_REVISION,
                             KEY_ALL_ACCESS,
                             psidAdministrators)) return FALSE;

    if (!AddAccessAllowedAce(pNewDACL,
                             ACL_REVISION,
                             KEY_ALL_ACCESS,
                             psidSystem)) return FALSE;

    if (!InitializeSecurityDescriptor(psdAbsoluteSD,
                                      SECURITY_DESCRIPTOR_REVISION)) return FALSE;

    if (!SetSecurityDescriptorDacl(psdAbsoluteSD,
                                   TRUE,      // fDaclPresent flag
                                   pNewDACL,
                                   FALSE))    // not a default DACL
                                           return FALSE;

    if (!IsValidSecurityDescriptor(psdAbsoluteSD)) return FALSE;

    lRv=RegSetKeySecurity(hKey,
                         (SECURITY_INFORMATION)(DACL_SECURITY_INFORMATION),
                         psdAbsoluteSD);
    if (lRv!=ERROR_SUCCESS) return FALSE;

    return TRUE;
}

*)

function do_SetRegACL: boolean;
var
  sia: TSIDIdentifierAuthority;
  pInteractiveSid, pAdministratorsSid: PSID;
  sd: Windows.TSecurityDescriptor;
  pDacl: PACL;
  dwAclSize: DWORD;
  aHKey: HKEY;
  lRetCode: longint;
  bSuccess: boolean;
begin

  sia.Value[0] := 0;
  sia.Value[1] := 0;
  sia.Value[2] := 0;
  sia.Value[3] := 0;
  sia.Value[4] := 0;
  sia.Value[5] := BSECURITY_NT_AUTHORITY;
  pInteractiveSid := nil;
  pAdministratorsSid := nil;
  pDacl := nil;

  bSuccess := false; // assume this function fails

  //
  // open the key for WRITE_DAC access
  //
  lRetCode := RegOpenKeyEx(
    HKEY_CURRENT_USER,
    'SOFTWARE\Test',
    0,
    WRITE_DAC,
    aHKey
    );

  if (lRetCode <> ERROR_SUCCESS) then
  begin
    ShowMessage('Error in RegOpenKeyEx');
    result := false;
  end;

  //
  // prepare a Sid representing any Interactively logged-on user
  //
  if (not AllocateAndInitializeSid(
    sia,
    1,
    SECURITY_INTERACTIVE_RID,
    0, 0, 0, 0, 0, 0, 0,
    pInteractiveSid
    )) then
  begin
    ShowMessage('Error in: AllocateAndInitializeSid');
    //goto cleanup;
  end;

  //
  // prepare a Sid representing the well-known admin group
  //
  if (not AllocateAndInitializeSid(
    sia,
    2,
    SECURITY_BUILTIN_DOMAIN_RID,
    DOMAIN_ALIAS_RID_ADMINS,
    0, 0, 0, 0, 0, 0,
    pAdministratorsSid
    )) then
  begin
    ShowMessage('Error in: AllocateAndInitializeSid');
    // goto cleanup;
  end;

  //
  // compute size of new acl
  //
  dwAclSize := sizeof(TACL) +
    2 * (sizeof(TAccess_Allowed_ACE) - sizeof(DWORD)) +
    GetLengthSid(pInteractiveSid) +
    GetLengthSid(pAdministratorsSid);

  //
  // allocate storage for Acl
  //
  pDacl := PACL(HeapAlloc(GetProcessHeap(), 0, dwAclSize));
  //if(pDacl == nil) goto cleanup;

  if (not InitializeAcl(pDacl^, dwAclSize, ACL_REVISION)) then
  begin
    ShowMessage('Error in: InitializeAcl');
    //goto cleanup;
  end;

  //
  // grant the Interactive Sid KEY_READ access to the perf key
  //
  if (not AddAccessAllowedAce(
    pDacl^,
    ACL_REVISION,
    KEY_READ,
    pInteractiveSid
    )) then
  begin
    ShowMessage('Error in: AddAccessAllowedAce');
    //goto cleanup;
  end;

  //
  // grant the Administrators Sid KEY_ALL_ACCESS access to the perf key
  //
  if (not AddAccessAllowedAce(
    pDacl^,
    ACL_REVISION,
    KEY_ALL_ACCESS,
    pAdministratorsSid
    )) then
  begin
    ShowMessage('Error in: AddAccessAllowedAce');
    //goto cleanup;
  end;

  if (not InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION)) then
  begin
    ShowMessage('Error in: InitializeSecurityDescriptor');
    //goto cleanup;
  end;

  if (not SetSecurityDescriptorDacl(@sd, TRUE, pDacl, FALSE)) then
  begin
    ShowMessage('Error in: SetSecurityDescriptorDacl');
    //goto cleanup;
  end;

  //
  // apply the security descriptor to the registry key
  //
  lRetCode := RegSetKeySecurity(
    aHKey,
    SECURITY_INFORMATION(DACL_SECURITY_INFORMATION),
    @sd
    );

  if (lRetCode <> ERROR_SUCCESS) then
  begin
    ShowMessage('Error in: RegSetKeySecurity');
    //goto cleanup;
  end;

  bSuccess := TRUE; // indicate success

end;

end.

Make a form use two frames in separate units

Problem/Question/Abstract:

How can I make a function which will create a frame (given its class) in a new form?

Answer:

Maybe you should use an enumerated value which is an index of an array of your frame classes. An example with a form using two frames in seperate units:

unit UnitTestForm;

interface

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

type
  {'class of' and enumeration}
  TFrameClass = class of TFrame;
  TFrameEnm = (frm_one, frm_two);

  {array of classes}
  TFrameClasses = array[TFrameEnm] of TFrameClass;

  {test form}
  TForm1 = class(TForm)
    btnCreateFrame1: TButton;
    btnCreateFrame2: TButton;
    procedure btnCreateFrame1Click(Sender: TObject);
    procedure btnCreateFrame2Click(Sender: TObject);
  private
    function CreateFrame(FrameEnm: TFrameEnm): TForm;
  public
  end;

var
  Frames: TFrameClasses = (TFrameOne, TFrameTwo);

  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnCreateFrame1Click(Sender: TObject);
var
  Form: TForm;
begin
  Form := Self.CreateFrame(frm_one);
  Form.ShowModal;
end;

procedure TForm1.btnCreateFrame2Click(Sender: TObject);
var
  Form: TForm;
begin
  Form := Self.CreateFrame(frm_two);
  Form.ShowModal;
end;

function TForm1.CreateFrame(FrameEnm: TFrameEnm): TForm;
var
  aFrame: TFrame;
begin
  Result := TForm.Create(nil);
  aFrame := Frames[FrameEnm].Create(Result);
  aFrame.Parent := Result;
  aFrame.Align := alClient;
end;

How to convert accented characters to unaccented ones

Problem/Question/Abstract:

Is there a way to convert accented characters to unaccented (meaning ASCII A - Z, a - z)?

Answer:

The classical way is to have a conversion table and do a lookup in that table. The problem with that is that the table is of course specific to a certain charset (encoding), like Windows Latin-1. You could build a table for a range of UNICODE (widechar) characters to get around this limitation and convert the strings to widestrings before you do the accent removals. The routine below uses ANSI characters with the Windows western (Latin-1) encoding.

function SimplifyChar(const _ch: char): char;
const
  Charmap: array[#128..#255] of Char = (
    #128 { ? }, #129 { ? }, #130 { ? }, #131 { ? }, #132 { ? },
    #133 { ? }, #134 { ? }, #135 { ? }, #136 { ? }, #137 { ? },
    #138 { ? }, #139 { ? }, #140 { ? }, #141 { ? }, #142 { ? },
    #143 { ? }, #144 { ? }, #145 { ? }, #146 { ? }, #147 { ? },
    #148 { ? }, #149 { ? }, #150 { ? }, #151 { ? }, #152 { ? },
    #153 { ? }, #154 { ? }, #155 { ? }, #156 { ? }, #157 { ? },
    #158 { ? }, #159 { ? }, #160 { � }, #161 { &middot; }, #162 { � },
    #163 { � }, #164 { � }, #165 { � }, #166 { &brvbar; }, #167 { � },
    #168 { � }, #169 { &copy; }, #170 { � }, #171 { &laquo; }, #172 { &not; },
    #173 {  }, #174 { &reg; }, #175 { � }, #176 { � }, #177 { &plusmn; },
    #178 { � }, #179 { � }, #180 { � }, #181 { &micro; }, #182 { &para; },
    #183 { &middot; }, #184 { � }, #185 { &plusmn; }, #186 { � }, #187 { &raquo; },
    #188 { � }, #189 { � }, #190 { &micro; }, #191 { � }, 'A' { � },
    'A' { � }, 'A' { � }, 'A' { � }, 'A' { � }, 'A' { � },
    #198 { � }, #199 { � }, 'E' { � }, 'E' { � }, 'E' { � },
    'E' { � }, 'I' { � }, 'I' { � }, 'I' { � }, 'I' { � },
    #208 { � }, #209 { � }, 'O' { � }, 'O' { � }, 'O' { � },
    'O' { � }, 'O' { � }, #215 { � }, #216 { � }, 'U' { � },
    'U' { � }, 'U' { � }, 'U' { � }, #221 { � }, #222 { � },
    #223 { � }, 'a' { � }, 'a' { � }, 'a' { � }, 'a' { � },
    'a' { � }, 'a' { � }, #230 { � }, #231 { � }, 'e' { � },
    'e' { � }, 'e' { � }, 'e' { � }, 'i' { � }, 'i' { � },
    'i' { � }, 'i' { � }, #240 { � }, #241 { � }, 'o' { � },
    'o' { � }, 'o' { � }, 'o' { � }, 'o' { � }, #247 { � },
    #248 { � }, 'u' { � }, 'u' { � }, 'u' { � }, 'u' { � },
    #253 { � }, #254 { � }, #255 { � }
    );
begin
  if _ch >= #128 then
    Result := Charmap[_ch]
  else
    Result := _ch;
end;

The charmap table was created by this little routine and then edited:

procedure CreateCharacterMap(fromchar, tochar: Char);

function DisplayStr(const ch: Char): string;
begin
  if ch < #32 then
    Result := '^' + Chr(Ord('A') - 1 + Ord(ch))
  else
    Result := ch;
end;

var
  sl: TStringlist;
  line, element: string;
  ch: char;
begin
  Assert(fromchar <= tochar);
  sl := Tstringlist.Create;
  try
    sl.Add('Const');
    line := Format('  Charmap: array [#%d..#%d] of Char = (', [Ord(fromchar),
      Ord(tochar)]);
    sl.Add(line);
    line := '';
    for ch := fromchar to toChar do
    begin
      element := Format('#%3.3d { %s }', [Ord(ch), DisplayStr(ch)]);
      if (Length(line) + Length(element)) > 66 then
      begin
        sl.Add('    ' + line);
        line := '';
      end;
      line := line + element;
      if ch <> tochar then
        line := line + ', ';
    end;
    sl.Add('    ' + line);
    sl.add('    );');
    Clipboard.AsText := sl.Text;
  finally
    sl.Free
  end;
end;