Local Routines or Nested Routines

Problem/Question/Abstract:

How to declare Local routines in delphi ?

Answer:

It is possible to declare local procedures or Functions within a procedure or function. Though it seems some how unusual at the first glance to declare Local routines within a routine, it is efficient to do this. If we do not need them anywhere other than the routine, why should make them public even within the unit ? Let us place them in their proper place, proper routines in proper place !

We declare local variables, constants and types before the BEGIN statement of a function or procedure. We can also include local routines here. Though it is efficient to include local routines here, but, in practice, very few delphi programmers use these techniques.

Example:

procedure PublicProc(p1: TypeofP1; p2: TypeofP2; ....pn: TypeOfPn);
var
  v1: TypeofV1;
  V2: TypeofV2;
  .....
  Vn: TypeofVn;
const
  c1: TypeofC1;
  {  ............ }
  {  ............ }

  procedure LocalProcedure1(p1: TypeofP1; p2: TypeofP2; ....pn: TypeOfPn);
  var
    {  ............ }
    {  ............ }
  begin
    {  ............ }
    {  ............ }
  end;
  procedure LocalProcedure2(p1: TypeofP1; p2: TypeofP2; ....pn: TypeOfPn);
  var
    {  ............ }
    {  ............ }
  begin
    {  ............ }
    {  ............ }
  end;
  function LocalFunction1(p1: TypeofP1; p2: TypeofP2; ....pn: TypeOfPn): ResultType;
  var
    {  ............ }
    {  ............ }
  begin
    {  ............ }
    {  ............ }
    result := {..... }
  end;
  function LocalFunction2(p1: TypeofP1; p2: TypeofP2; ....pn: TypeOfPn): ResultType;
  var
    {  ............ }
    {  ............ }
  begin
    {  ............ }
    {  ............ }.
    result := {..... }
  end;

begin {PublicProc}
  ...........
    '''''''''''
    LocalProcedure1(...., ...., ....);
    ...........
    LocalProcedure2(...., ...., ....);
    ...........
    v1 := LocalFunction1(...., ...., ....);
    ...........
    v2 := LocalFunction2(...., ...., ....);
    ...........
    '''''''''''
end; {PublicProc}

In this example, the scope of the nested routines
LocalProcedure1,
LocalProcedure2,
LocalFunction1 and
LocalFunction2  
is limited only to PublicProc. No other routines in the same unit or in other
units can see them.

Show a hint for an iconized application

Problem/Question/Abstract:

I need to show some information to the user when the mouse moves over the icon in the tray sector. I am using the Shell_NotifyIcon funtion with NIM_ADD, NIM_DELETE parameters to show or not show the icon. How to show that hint?

Answer:

It is automatic, you only need to tell Shell_NotifyIcon which hint to use.

{Update the tray icons tooltip}

procedure UpdateTrayTip;
var
  nim: TNotifyIconData;
begin
  FillChar(nim, sizeof(nim), 0);
  nim.cbSize := Sizeof(nim);
  nim.Wnd := wnd;
  nim.uID := ICONID;
  nim.uFlags := NIF_TIP;
  StrLCopy(nim.szTip, GetTrayTooltip, Sizeof(nim.szTip) - 1);
  Shell_NotifyIcon(NIM_MODIFY, @nim);
end;

GetTrayTooltip is a function that in my case returns a PChar pointing at an entry in a constant array of Pchars. You can use StrPLCopy if you have a String holding the tooltip instead. You can set the tip on NIM_ADD as well.

Create an Access database at runtime

Problem/Question/Abstract:

How to create an Access database at runtime

Answer:

Solve 1:

Here is an OP function that will do it for you:

procedure CreateMSAccessDB(filename: string);
var
  DBEngine, Workspace: Variant;
const
  {Important to use the following constant as is}
  dbLangGeneral = '';
  LANGID = 0x0409;
  CP = 1252;
  COUNTRY = '0';
  dbVersion30 = 32;
begin
  DBEngine := CreateOleObject('DAO.DBEngine');
  {DBEngine := CreateOleObject('DAO.DBEngine.35'); For DAO 3.5}
  Workspace := DBEngine.Workspaces[0];
  try
    Workspace.CreateDatabase(filename, dbLangGeneral, dbVersion30);
  except
    on EOleException do
      ShowMessage('Database already exists');
  end;
end;


Solve 2:

It's very simple to create a empty Access-Database (*.mdb File) using OLE. It's not necessary to have MS-Access installed on your computer. If an exception occures the error message will returned. After creating the DB you can create Tables with simple SQL-Statements.

uses comobj, sysutils;

function CreateAccessDatabase(FileName: string): string;
var
  cat: OLEVariant;
begin
  result := '';
  try
    cat := CreateOleObject('ADOX.Catalog');
    cat.create('Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + Filename + ';');
    cat := NULL;
  except
    on e: Exception do
      result := e.message;
  end;
end;

Files used/created by Delphi

Problem/Question/Abstract:

Files used/created by Delphi

Answer:

Here is a list of the file extensions created by Delphi and what they all mean:

DPR - Delphi Project File. This is actually a Pascal source file; it just happens to be the main program for the application.
PAS - In Delphi, PAS files are always the source code to either a unit or a form. The main program of an application is in the DPR file.
DFM - These files are always paired with PAS files. The DFM file is the binary data used to set up initial data for components (IE, the properties you set in design mode rather than in code). You can't edit a DFM file with a text editor, but if you open it in Delphi, you will see a textual version of the contents.
DCU - A compiled unit, similar in concept to an OBJ file.
OPT - Project Options; i.e. compiler and linker settings, which form is the main form, what icon to use for the application, etc. Generally, the stuff you edit under Options/Project.
RES - A Windows resource file; generated automatically by Delphi and required by the compilation process. You don't need to worry about this file, but don't delete it either.
EXE - All of the above linked together into runnable format.
~DP - A backup file of the DPR file before the last save operation.
~PA - A backup of a .PAS file.
~DF - A backup of a .DFM file.

UnDo in a memo field

Problem/Question/Abstract:

UnDo in a memo field

Answer:

If you have a pop-up menu in a TMemo, and put shortcuts on it for the Cut, Copy, Paste, then you can handle those events, and call CuttoClipBoard, CopytoClipBoard, etc.

However, if you put an Undo option onto your pop-up menu (normally Ctrl-Z), how do you instruct the TMemo to do the Undo?

If the built-in undo is sufficient, you can get it easier than a Ctrl+Z:


Memo1.Perform(EM_UNDO, 0, 0);


To check whether undo is available so as to enable/disable
an undo menu item:


Undo1.Enabled := Memo1.Perform(EM_CANUNDO, 0, 0) <> 0;

How to calculate Easter Day for a specified year

Problem/Question/Abstract:

How to calculate Easter Day for a specified year

Answer:

function Easter(Year: Integer): TDateTime;
var
  nMonth, nDay, nMoon, nEpact, nSunday, nGold, nCent, nCorx, nCorz: Integer;
begin
  { The Golden Number of the year in the 19 year Metonic Cycle: }
  nGold := (Year mod 19) + 1;
  { Calculate the Century: }
  nCent := (Year div 100) + 1;
  { Number of years in which leap year was dropped in order to keep in step with the sun: }
  nCorx := (3 * nCent) div 4 - 12;
  { Special correction to syncronize Easter with moon's orbit: }
  nCorz := (8 * nCent + 5) div 25 - 5;
  { Find Sunday: }
  nSunday := (Longint(5) * Year) div 4 - nCorx - 10; { To prevent overflow at year 6554}
  { Set Epact - specifies occurrence of full moon: }
  nEpact := (11 * nGold + 20 + nCorz - nCorx) mod 30;
  if nEpact < 0 then
    nEpact := nEpact + 30;
  if ((nEpact = 25) and (nGold > 11)) or (nEpact = 24) then
    nEpact := nEpact + 1;
  { Find Full Moon: }
  nMoon := 44 - nEpact;
  if nMoon < 21 then
    nMoon := nMoon + 30;
  { Advance to Sunday: }
  nMoon := nMoon + 7 - ((nSunday + nMoon) mod 7);
  if nMoon > 31 then
  begin
    nMonth := 4;
    nDay := nMoon - 31;
  end
  else
  begin
    nMonth := 3;
    nDay := nMoon;
  end;
  Easter := EncodeDate(Year, nMonth, nDay);
end;

TString Super Sort Class (Descending,Ignore Case and other)

Problem/Question/Abstract:

TStringList has a Sort method and a Sorted property. This feature is not available in it's useful descendant TStrings. This class allows sorting of TString objects with extra functionality ala UNIX style parameters. (Yes I know UNIX is a four letter word but they do have some neat features). The SORT algorythm utilizes the QUICK SORT method.

Answer:

The features I have implemented are

  Options
    SORT DESCENDING                                                  - srtDescending
    TREAT SORT FIELD AS NUMERIC              - srtEvalNumeric
    IGNORE LEADING BLANKS IN FIELD          - srtIgnoreBlank
    IGNORE CASE OF FIELD                                             - srtIgnoreCase

  Switches
    -k Start,End position of substring for search
    -f Field number of a delimited string (Zero column based)
    -d Character delimiter for -f switch (Default = SPACE)

In it's simplest form it just sorts the TStrings ascending
eg.  SuperSort.SortStrings(Memo1.Lines,[]);

Assume a semi-colon delimited list like ..
    'Mike;34;Green'
    'harry;25;Red'
    'Jackie;6;Black'
    'Bazil;9,Pink'
    'john;52;Blue'

To sort this list DESCENDING on AGE (Field 1) and ignore case
     SuperSort(MyStrings, ['-f 1','-d ;'], [srtDescending,srtEvalNumeric,srtIgnoreCase]);

Assume a string list of ...
    '1999 12 20 AA432 Comment 1'
    '2002 10 12 SWA12 Some other words'
    '1998 09 11 BDS65 And so on and so on'

To sort this list on ITEM CODE (Positions 12 to 17) with no options
     SuperSort(MyStrings,['-k 12,17']);


Methods :

procedure SortStrings(StringList : TStrings;  Switches : array of string;  
                                     Options : TSuperSortOptionSet = []);

   Switches is a string array of -k,-d and -f settings. If it is set to empty array [] then NO switches are active.

   Options is an OPTIONAL set of [srtDescending,srtIgnoreCase,srtIgnoreBlank,srtEvalNumeric]
   The default is empty set []

Properties :

SortTime : TDateTime;

   Returns the time taken for the sort for stats purposes.

Usage Example :

uses SuperSort;

procedure TForm1.Test;
var
  Srt: TSuperSort
begin
  Srt := TSuperSort.Create;
  Srt.SortStrings(Memo1.Lines, [], [srtIgnoreBlank]);
  Label1.Caption := 'Time : ' + FormatDateTine('hh:nn:ss:zzz',Srt.SortTime);
  Srt.Free;
end;

Unit TSuperSort:

unit SuperSort;
interface
uses Classes, SysUtils;

// =============================================================================
// Class TSuperSort
// Mike Heydon Nov 2002
//
// Sort class that implements Unix style sorts including ..
//
// SWITCHES
// --------
// -k [StartPos,EndPos]  - Keyfield to sort on. Start and End pos in string
// -d [Field Delimiter]  - Delimter to use with -f switch. default = SPACE
// -f [FieldNumber]      - Zero based field number delimeted by -d
//
// OPTIONS SET
// ============
// srtDescending         - Sort descending
// srtIgnoreCase         - Ignore case when sorting
// srtIgnoreBlank        - Ignore leading blanks
// srtEvalNumeric        - Treat sort items as NUMERIC
//
// =============================================================================

type
  // Sort Options
  TSuperSortOptions = (srtDescending, srtIgnoreCase,
    srtIgnoreBlank, srtEvalNumeric);
  TSuperSortOptionSet = set of TSuperSortOptions;

  // ============
  // TSuperSort
  // ============
  TSuperSort = class(TObject)
  protected
    function GetKeyString(const Line: string): string;
    procedure QuickSortStrA(SL: TStrings);
    procedure QuickSortStrD(SL: TStrings);
    procedure ResolveSwitches(Switches: array of string);
  private
    FSortTime: TDateTime;
    FIsSwitches,
      FIsPositional,
      FIsDelimited,
      FDescending,
      FIgnoreCase,
      FIgnoreBlank,
      FEvalDateTime,
      FEvalNumeric: boolean;
    FFieldNum,
      FStartPos, FEndPos: integer;
    FDelimiter: char;
  public
    procedure SortStrings(StringList: TStrings;
      Switches: array of string;
      Options: TSuperSortOptionSet = []);
    property SortTime: TDateTime read FSortTime;
  end;

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

const
  BLANK = -1;
  EMPTYSTR = '';

  // ================================================
  // INTERNAL CALL
  // Resolve switches and set internal variables
  // ================================================

procedure TSuperSort.ResolveSwitches(Switches: array of string);
var
  i: integer;
  Sw, Data: string;
begin
  FStartPos := BLANK;
  FEndPos := BLANK;
  FFieldNum := BLANK;
  FDelimiter := ' ';
  FIsPositional := false;
  FIsDelimited := false;

  for i := Low(Switches) to High(Switches) do
  begin
    Sw := trim(Switches[i]);
    Data := trim(copy(Sw, 3, 1024));
    Sw := UpperCase(copy(Sw, 1, 2));

    // Delimiter
    if Sw = '-D' then
    begin
      if length(Data) > 0 then
        FDelimiter := Data[1];
    end;

    // Field Number
    if Sw = '-F' then
    begin
      FIsSwitches := true;
      FIsDelimited := true;
      FFieldNum := StrToIntDef(Data, BLANK);
      Assert(FFieldNum <> BLANK, 'Invalid -f Switch');
    end;

    // Positional Key
    if Sw = '-K' then
    begin
      FIsSwitches := true;
      FIsPositional := true;
      FStartPos := StrToIntDef(trim(copy(Data, 1, pos(',', Data) - 1)), BLANK);
      FEndPos := StrToIntDef(trim(copy(Data, pos(',', Data) + 1, 1024)), BLANK);
      Assert((FStartPos <> BLANK) and (FEndPos <> Blank), 'Invalid -k Switch');
    end;

  end;
end;

// ====================================================
// INTERNAL CALL
// Resolve the Sort Key part of the string based on
// the Switches parameters
// ====================================================

function TSuperSort.GetKeyString(const Line: string): string;
var
  Key: string;
  Numvar: double;
  DCount, i, DPos: integer;
  Tmp: string;
begin
  // Default
  Key := Line;
  // Extract Key from switches -k takes precedence
  if FIsPositional then
    Key := copy(Key, FStartPos, FEndPos)
  else if FIsDelimited then
  begin
    DPos := 0;
    DCount := 0;
    for i := 1 to length(Key) do
    begin
      if Key[i] = FDelimiter then
        inc(DCount);
      if DCount = FFieldNum then
      begin
        if FFieldNum = 0 then
          DPos := 1
        else
          DPos := i + 1;
        break;
      end;
    end;

    if DCount < FFieldNum then
      // No such Field Number
      Key := EMPTYSTR
    else
    begin
      Tmp := copy(Key, DPos, 4096);
      DPos := pos(FDelimiter, Tmp);
      if DPos = 0 then
        Key := Tmp
      else
        Key := copy(Tmp, 1, DPos - 1);
    end;
  end;

  // Resolve Options
  if FEvalNumeric then
  begin
    Key := trim(Key);
    // Strip any commas
    for i := length(Key) downto 1 do
      if Key[i] = ',' then
        delete(Key, i, 1);
    try
      Numvar := StrToFloat(Key);
    except
      Numvar := 0.0;
    end;
    Key := FormatFloat('############0.000000', Numvar);
    // Leftpad num string
    Key := StringOfChar('0', 20 - length(Key)) + Key;
  end;

  // Ignores N/A for Numeric and DateTime
  if not FEvalNumeric and not FEvalDateTime then
  begin
    if FIgnoreBlank then
      Key := trim(Key);
    if FIgnoreCase then
      Key := UpperCase(Key);
  end;

  Result := Key;
end;

// ==============================================
// INTERNAL CALL
// Recursive STRING quick sort routine ASCENDING.
// ==============================================

procedure TSuperSort.QuickSortStrA(SL: TStrings);

  procedure Sort(l, r: integer);
  var
    i, j: integer;
    x, Tmp: string;
  begin
    i := l;
    j := r;
    x := GetKeyString(SL[(l + r) div 2]);

    repeat
      while GetKeyString(SL[i]) < x do
        inc(i);
      while x < GetKeyString(SL[j]) do
        dec(j);
      if i <= j then
      begin
        Tmp := SL[j];
        SL[j] := SL[i];
        SL[i] := Tmp;
        inc(i);
        dec(j);
      end;
    until i > j;

    if l < j then
      Sort(l, j);
    if i < r then
      Sort(i, r);
  end;

begin
  if SL.Count > 0 then
  begin
    SL.BeginUpdate;
    Sort(0, SL.Count - 1);
    SL.EndUpdate;
  end;
end;

// ==============================================
// INTERNAL CALL
// Recursive STRING quick sort routine DECENDING
// ==============================================

procedure TSuperSort.QuickSortStrD(SL: TStrings);
  procedure Sort(l, r: integer);
  var
    i, j: integer;
    x, Tmp: string;
  begin
    i := l;
    j := r;
    x := GetKeyString(SL[(l + r) div 2]);

    repeat
      while GetKeyString(SL[i]) > x do
        inc(i);
      while x > GetKeyString(SL[j]) do
        dec(j);
      if i <= j then
      begin
        Tmp := SL[j];
        SL[j] := SL[i];
        SL[i] := Tmp;
        inc(i);
        dec(j);
      end;
    until i > j;

    if l < j then
      Sort(l, j);
    if i < r then
      Sort(i, r);
  end;

begin
  if SL.Count > 0 then
  begin
    SL.BeginUpdate;
    Sort(0, SL.Count - 1);
    SL.EndUpdate;
  end;
end;

// ====================
// Sort a stringlist
// ====================

procedure TSuperSort.SortStrings(StringList: TStrings;
  Switches: array of string;
  Options: TSuperSortOptionSet = []);
var
  StartTime: TDateTime;
begin
  StartTime := Now;
  FDescending := (srtDescending in Options);
  FIgnoreCase := (srtIgnoreCase in Options);
  FIgnoreBlank := (srtIgnoreBlank in Options);
  FEvalNumeric := (srtEvalNumeric in Options);
  ResolveSwitches(Switches);

  if FDescending then
    QuickSortStrD(StringList)
  else
    QuickSortStrA(StringList);

  FSortTime := Now - StartTime;
end;

end.

How to store fonts in a resource file

Problem/Question/Abstract:

Is there a way to store a particular font in an *.ini type of file so that it can be recalled when an application starts?

Answer:

There may be copyright issues with Fonts. With that said, you can include the font directly in you program with a resource file.

Using your favorite text editor, create a *.rc file that describes the font:

MY_FONT ANYOL1 "Bauhs93.ttf"

The first two parameters can be whatever you want. They get used in your program later. Then, use the BRCC32.EXE command line compiler that ships with Delphi to create a *.res file. If your file in step 1 was MyFont.rc, the command from the DOS prompt would be:

BRCC32 MyFont

The program will append the .rc to the input, and create a file with the same name except it appends .res: MyFont.res . In your program, add a compiler directive to include your newly created file:

{$R MyFont.res}

This can go right after the default {$R *.DFM} in the implementation section. Add a procedure to create a file from the resource, then make the Font available for use. Example:

procedure TForm1.FormCreate(Sender: TObject);
var
  Res: TResourceStream;
begin
  Res := TResourceStream.Create(hInstance, 'MY_FONT', Pchar('ANYOL1'));
  Res.SavetoFile('Bauhs93.ttf');
  Res.Free;
  AddFontResource(PChar('Bauhs93.ttf'));
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

You can now assign the font to whatever you wish:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Button1.Font.Name := 'Bauhaus 93';
end;


Caveats:

The above example provides for no error checking whatsoever. The user may already have that font installed.

Notice that the File name is NOT the same as the Font name. It's assumed that you know the font name associated with the file name. You can determine this by double clicking on the file name in the explorer window.

I would recommend placing your font file in the C:\WINDOWS\FONTS folder. It's easier to find them later.

Your newly installed font can be removed programatically, assuming the font is not in use anywhere:

procedure TForm1.FormDestroy(Sender: TObject);
begin
  RemoveFontResource(PChar('Bauhs93.ttf'));
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

How to calculate intersection points of lines or line sections with rectangles

Problem/Question/Abstract:

How to calculate intersection points of lines or line sections with rectangles

Answer:

function fuzz(x, fuzzFactor: double): double;
var
  s: string;
begin
  s := format('%.6f', [x]);
  result := StrToFloat(s);
end;


Warning : this function assumes a fuzz factor in comparing values of doubles. This is because
of the tendency of zero sloped edges to need some help in avoiding div-by-zero errors.


function Intersection(p1, p2, p3, p4: pt; var err: boolean): pt;
var
  m1, m2, b1, b2: double;
  pResult: pt;
begin
  err := false;
  if p2.x = p1.x then
    m1 := MaxReal
  else
    m1 := (p2.y - p1.y) / (p2.x - p1.x);
  if p4.x = p3.x then
    m2 := MaxReal
  else
    m2 := (p4.y - p3.y) / (p4.x - p3.x);
  if m1 = m2 then
  begin {parallel lines never intersect}
    err := true;
    exit;
  end;
  b1 := (p1.y) - (m1 * p1.x);
  b2 := (p3.y) - (m2 * p3.x);
  if m2 = 0 then
    pResult.y := p3.y
  else if m1 = 0 then
    pResult.y := p1.y
  else
    pResult.y := ((m1 * b2) - (m2 * b1)) / (m1 - m2);
  if (fuzz(m1, 0.0001)) = fuzz(MaxReal, 0.00001) then
    pResult.x := p1.x
  else if m1 = 0 then
    if fuzz(m2, 0.00001) = fuzz(MaxReal, 0.00001) then
      pResult.x := p3.x
    else
      pResult.x := (pResult.y - b1) {/ 0.00001}
  else
    pResult.x := (pResult.y - b1) / m1;
  Result := pResult;
end;

How to create context-sensitive help

Problem/Question/Abstract:

How to create context-sensitive help

Answer:

Introduction:

Windows 95 has much better context-sensitive help than Windows 3.1, with support for the small ? button in dialogs and right-button 'What's This?' help. These features allow users to get instant help in dialogs, without opening Help in a separate window. This integration between Help and your application is very user-friendly and makes the program look very professional. Also, your Help file stays smaller because you don't have to include screenshots for all dialogs. Delphi 2.0 allows you to make use of context-sensitive help, but it is not straightforward. Especially using the What's This function requires some investigation.

The goal of this document is to aid Delphi 2.0 developers in adding context-sensitive Help to their application, so that you do not have to reinvent the wheel. You are assumed to have knowledge of Delphi programming and help authoring, and have access to Delphi 2.0, the Help Workshop (provided with the Help Authoring Guide) and a word processor to create .RTF files (or whatever method you use to create help files).



Steps:

Create topics in your Help file that you want to be used as popup-help for dialog controls
Create an include file which contains the mapping of Pascal constants to help identifiers (say mapping.inc)
Add two lines helpcontextidentifier=uniquenumber and ';' i.e. helpokbutton = 1000; for each help topic. The second line with the semi-colon is necessary to allow us to use the include file both in Delphi and Help Workshop
In your Help project file, specify mapping.inc as the Map file
Create a data module in your Delphi project, if you didn't already have one
In the data module add an include statement {$I mapping.inc} preceded by a const statement
Add a TPopupMenu component to the data module, and add one menu-item with the text 'What's This?'
Create an event handler for the OnClick event of this menu item, and add the code shown in bold



The resulting data module code (without any other components you may have in it) should now look like this (I named the module dmMain):


unit Datamodule;

interface

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

type
  TdmMain = class(TDataModule)
    PopupMenu1: TPopupMenu;
    procedure WhatsThis1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  dmMain: TdmMain;

implementation

{$R *.DFM}

procedure TdmMain.WhatsThis1Click(Sender: TObject);
var
  P: TControl;
begin
  with PopupMenu1 do
  begin
    if PopupComponent is TControl then
    begin
      P := PopupComponent as TControl;
      {locate the closest ancestor with a valid HelpContext}
      while (P <> nil) and (not (P is TWinControl) or ((P as TWinControl).HelpContext = 0)) do
        P := P.Parent;
      if (P <> nil) then
        Application.HelpCommand(HELP_CONTEXTPOPUP, Longint((P as TWinControl).HelpContext));
    end;
  end;
end;



In the dialog form, be sure to specify the bordericons as [biHelp] or [biSystemMenu, biHelp] and the border style as bsSingle, to enable the small ? button in the caption of the form
For each control you want What's This help, specify the dmMain.PopupMenu1 as the PopupMenu property
In the OnCreate event handler for the form containing the controls, add a line for each control in the form of: Control1.HelpContext := helpcontextidentifier; where helpcontextidentifier is the constant defined in mapping.inc for this control.



That's it! Compile the Delphi project and the Help project and everything should work. Note that I used a single TPopupMenu for all controls across all dialogs - this is the strength of the data module at work. Now that you have this framework set up, providing context-sensitive help for each new control you add consists of just four steps:



Create a topic for it in the Help source
Create an entry in the mapping file
Add one line in the OnCreate of the form containing the control
Set the PopupMenu of the control to the data module popupmenu.



Remark:

According to the documentation in the Help Authoring Guide, you should create a WndProc in your form to catch the WM_CONTEXTMENU message and respond to it by calling WinHelp() with the control id (coming from Msg.wParam) as the handle, plus an array containing (handle,help topic) pairs. However, apart from being rather cumbersome, this doesn't work for controls which have a parent (like controls on a PageControl) because the handle being passed is the parent's, not the child's. The Help system itself does provide a popup menu (using the HELP_CONTEXTMENU command), so recreating it in the Delphi project is not elegant. However, using the HELP_CONTEXTPOPUP command from Delphi and avoiding the messy WndProc business in my opinion outweighs this minor inelegance by far.

How to sort a TList

Problem/Question/Abstract:

How to sort a TList

Answer:

procedure BubbleSort(const List: TList; const Compare: TListSortCompare);
var
  Limit: Integer;
  I: Integer;
  Temp: Pointer;
  Swapped: Boolean;
begin
  for Limit := (List.Count - 1) downto 1 do
  begin
    Swapped := False;
    for I := 0 to (Limit - 1) do
      if (Compare(List[I], List[I + 1]) > 0) then
      begin
        Temp := List[I];
        List[I] := List[I + 1];
        List[I + 1] := Temp;
        Swapped := True;
      end;
    if (not Swapped) then
      Break;
  end;
end;

procedure InsertionSort(const List: TList; const Compare: TListSortCompare);
var
  Step: Integer;
  Temp: Pointer;
  I: Integer;
begin
  for Step := 1 to (List.Count - 1) do
  begin
    Temp := List[Step];
    for I := (Step - 1) downto 0 do
      if (Compare(List[I], Temp) > 0) then
        List[I + 1] := List[I]
      else
        Break;
    List[I + 1] := Temp;
  end;
end;

procedure ShellSort(const List: TList; const Compare: TListSortCompare);
var
  Step: Integer;
  H: Integer;
  I: Integer;
  Temp: Pointer;
begin
  H := 1;
  while (H <= (List.Count div 9)) do
    H := 3 * H + 1;
  while (H > 0) do
  begin
    for Step := H to (List.Count - 1) do
    begin
      Temp := List[Step];
      I := Step - H;
      while (I >= 0) do

      begin
        if (Compare(Temp, List[I]) < 0) then
          List[I + H] := List[I]
        else
          Break;
        Dec(I, H);
      end;
      List[I + H] := Temp;
    end;
    H := H div 3;
  end;
end;

procedure QuickSort1(const List: TList; const Compare: TListSortCompare;
  const L: Integer; const R: Integer);
var
  I: Integer;
  J: Integer;
  Temp: Pointer;
begin
  I := L - 1;
  J := R;
  repeat
    Inc(I);
    while (Compare(List[I], List[R]) < 0) do
      Inc(I);
    Dec(J);
    while (J > 0) do
    begin
      Dec(J);
      if (Compare(List[J], List[R]) <= 0) then
        Break;
    end;
    if (I >= J) then
      Break;
    Temp := List[I];
    List[I] := List[J];
    List[J] := Temp;
  until
    (False);
  Temp := List[I];
  List[I] := List[R];
  List[R] := Temp;
end;

procedure QuickSort(const List: TList; const Compare: TListSortCompare);
begin
  QuickSort1(List, Compare, 0, List.Count - 1);
end;

Anti Cheat code in savegame files

Problem/Question/Abstract:

Quick way to make Anti Cheat code in save game files using RandSeed

Answer:

unit Unit1;

interface

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

const
  NUM_CLUES = 50;
type
  Counter = Integer;
  TGameRec = record
    GameName: string[20];
    AnswerFound: array[1..NUM_CLUES] of boolean;
  end;

  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
uses
  INIFiles;

var
  GameRec: tGameRec;
  IniFileName: string;
  TheINI: TIniFile;

  { =============================================== }

procedure InitGameRec(var G: TGameRec);
var
  C: Counter;
begin
  with G do
  begin
    GameName := 'A Funny Test Game';
    for C := 1 to NUM_CLUES do
      AnswerFound[C] := false;
  end;
end;
{ =============================================== }

function AntiCheatString(R: TGameRec): string;
var
  aSeed: LongInt;
  S: string;
  C: counter;
begin
  S := '';
  aSeed := 999; // or somwthing else
  for C := 1 to length(R.GameName) do
    aSeed := aSeed + ord(R.GameName[C]);
  for C := 1 to NUM_CLUES do
    if R.AnswerFound[C] then
      aSeed := aSeed + 333 // or somwthing else
    else
      aSeed := aSeed + 666; // or somwthing else
  RandSeed := aSeed;
  for C := 1 to 50 do
    S := S + chr(random(26) + ord('A'));
  result := S;
end;
{ =============================================== }

procedure SaveINI;
var
  R: TGameRec;
  C: counter;
  S: string;
begin
  TheINI := TIniFile.Create(IniFileName);
  R := GameRec;
  TheINI.WriteString('Files', 'EXE File Name', ParamStr(0));
  TheIni.WriteString('Files', 'INI File Name', IniFileName);
  TheIni.WriteString('Game', 'Name', R.GameName);
  S := AntiCheatString(R);
  TheINI.WriteString('Anti Cheat Section', 'Code', S);
  for C := 1 to NUM_CLUES do
  begin
    S := 'Clue Number ' + IntToStr(C);
    TheINI.WriteBool('Clues', S, R.AnswerFound[C]);
  end;
  TheINI.Free;
end;
{ =============================================== }

function ReadINIOK: boolean;
var
  R: TGameRec;
  C: counter;
  aCode,
    S: string;
begin

  TheINI := TIniFile.Create(IniFileName);
  R.GameName := TheINI.ReadString('Game', 'Name', 'Not Found');
  for C := 1 to NUM_CLUES do
  begin
    S := 'Clue Number ' + IntToStr(C);
    R.AnswerFound[C] := theINI.ReadBool('Clues', S, false);
  end;
  aCode := TheINI.ReadString('Anti Cheat Section', 'Code', 'Cheat');
  TheINI.Free;

  S := AntiCheatString(R);
  result := (S = aCode);
end;
{ =============================================== }

procedure TForm1.FormCreate(Sender: TObject);
begin
  IniFileName := ExtractFileDir(paramStr(0)) + '\' + 'Test.ini';
  if not FileExists(IniFileName) then // save for 1st ever run
  begin
    InitGameRec(GameRec);
    SaveINI;
  end;
  if ReadINIOK then
    ShowMessage('Ini File OK')
  else
    ShowMessage('Ini File is no good');
end;

end.

How to read a TMemoField into a TMemo

Problem/Question/Abstract:

I would like to read the lines from a memo field into my program using FieldByName().As. There does not seem to be any way to move the memo into a TString or TStringList or to access the memo field on a line by line basis. You can use a String or Variant. When you do this you get just one long composite string. Can you help?

Answer:

Almost every TStrings descendant has a LoadFromStream method:

procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField);
var
  TB: TBlobStream;
begin
  with TDataSource(Sender).DataSet do
    if (State = dsBrowse) then
    begin
      TB := TBlobStream.create(FieldByName('Event_Description') as TBlobField, bmRead);
      Memo1.Lines.LoadFromStream(TB);
      {or ListBox1.items.LoadFromStream(TB);}
      {or StringList1.LoadFromStream(TB);}
      TB.Free;
    end;
end;

Add Taskbar-Button's for SubForms and manage them correctly

Problem/Question/Abstract:

I would like to add some Windows' Taskbar-Buttons for dynamic created forms w/o loosing the ability to 're-focus' the MainForm by clicking it's own button.

Answer:

The following example uses a Button (Button1)to dynamic create forms at runtime. Each form will be accessable via a corresponding Button placed on the Taskbar. You had to include the WMSysCommand method to enable the real "look&feel" of minimizing the MainForm. Otherwise, the MainForm will be minimized to the lower left side of the Screen or will be hidden in the background, so it's not possible to restore it correctly.

If you want to minimize (or hide) all subforms when minimizing the MainForm, you had to iterate through all registered subforms and hide them manualy. I don't know a better way right now, but if you've found any solution...:-)

MainForm Unit

unit MainForm;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure WMSysCommand(var Msg: TMessage); message WM_SYSCOMMAND;
  public
    { Public declarations }
    procedure CreateParams(var Params:
      TCreateParams); override;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

uses
  SubForm;

var
  SubForm: TSubForm;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  SetWindowLong(Application.Handle, GWL_EXSTYLE,
    GetWindowLong(Application.Handle, GWL_EXSTYLE) or
    WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW);
end;

procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW and not WS_EX_TOOLWINDOW;
end;

procedure TMainForm.WMSysCommand(var Msg: TMessage);
begin
  DefaultHandler(Msg);
end;

procedure TMainForm.Button1Click(Sender: TObject);
begin
  SubForm := TSubForm.Create(Application);
  SubForm.Show;
end;

end.

SubForm Unit

unit SubForm;

interface

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

type
  TSubForm = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure CreateParams(var Params: TCreateParams); override;
  end;

implementation

{$R *.DFM}

procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
end;

procedure TSubForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

end.

How to save two TStringlists to the same stream

Problem/Question/Abstract:

TStrings.LoadFromStream is assuming that itself consumes the rest of the stream! What if I want to save 2 stringlists to the same stream?

Answer:

That is as designed. Just use an intermediate stream to accomplish what you want. Or you can take the following approach using a string buffer:

{ ... }
var
  list1: TStringList;
  list2: TStringList;
  lng: cardinal;
  stream: TMemoryStream;
  tmpS: string;
begin
  list1 := TStringList.Create;
  list2 := TStringList.Create;
  try
    stream := TMemoryStream.Create;
    try
      {Assume there was code to get something into stream.
                        The layout of the stream is:
      size1|block1|size2|block2}
      {Read size of the 1st block}
      stream.Read(lng, SizeOf(lng));
      if lng > 0 then
      begin
        {if there are contents, read the block to tmpS}
        SetLength(tmpS, lng);
        stream.Read(tmpS[1], lng)
          {Assign tmpS to the Text property of list1}
        list1.Text := tmpS;
      end;
      {Same procedure for list2}
      stream.Read(lng, SizeOf(lng));
      if lng > 0 then
      begin
        SetLength(tmpS, lng);
        stream.Read(tmpS[1], lng)
          list2.Text := tmpS;
      end;
    finally
    end;
  finally
    list2.Free;
    list1.Free;
  end;
end;

Interbase Sweep on the Fly in a thread

Problem/Question/Abstract:

In the Interbase Admin components there is a IBValidationService but is hard to use as it is. Sweeping is just one of the functions of the validation service. This component makes doing sweeps of databases alot easier, and also works in a thread. Ideal for use in server applications.

Answer:

(*
  Interbase Sweep Thread

  Author
    Kim Sandell
    Email: kim.sandell@nsftele.com    

  Description
    A Thread that performs an Sweep of an interbase database on the fly.
    The thread can automatically free itself after the sweep is done.

    Note: This can be a lengthy process so make sure you do not interrupt
          the program in the middle of the sweep. The sweeping process
          can not be interrupted !!! It makes sense to let it run in the
          background and free itself if you have a server program !

    Parameters
    ----------
     DatabaseName       Full : to database
     DatabaseUsername   The name of the user with rights to sweep the db
     DatabasePassword   The password of the user
     FreeOnTerminate    Set this to false if you want to free the thread
                        yourself. Default is TRUE
     Priority           The priority of the thread. Default is tpLower

  Version
    1.0

  History
    24.09.2002  - Initial version

  Known issues
    None so far ...

  Example of usage

    The example below assumes you have included the "IBSweepThread" unit
    in the uses clause, and that you have a button on a form.

    The Thread must be created and the properties initialized, before the
    thread can be Resumed.

    procedure TForm1.Button1Click(Sender: TObject);
    Var
       IBSweep : TIBSweepThread;
    begin
         Try
            IBSweep := TIBSweepThread.Create( True );
            IBSweep.DatabaseName := '127.0.0.1:C:\Databases\MyIBDB.GDB';
            IBSweep.DatabaseUsername := 'SYSDBA';
            IBSweep.DatabasePassword := 'masterkey';
            IBSweep.FreeOnTerminate := False; // We want to see the results!
            IBSweep.Resume;
            { Wait for it }
            While Not IBSweep.Terminated do
            Begin
                 SleepEx(1,True);
                 Application.ProcessMessages;
            End;
            { Just make sure the thread is dead }
            IBSweep.WaitForAndSleep;
            { Check for success }
            If IBSweep.ResultState = state_Done then
            Begin
                 MessageDlg( 'Sweep OK - Time taken: '+
                             IntToStr(IBSweep.ProcessTime)+' ms',
                             mtInformation,[mbOK],0);
                 ShowMessage( IBSweep.SweepResult.Text );
            End Else MessageDlg('Sweep FAILED',mtError,[mbOK],0);
         Finally
            IBSweep.Free;
         End;
    end;
*)
unit IBSweepThread;

interface

uses
  Windows, Messages, SysUtils, Classes,
  IBServices;

const
  state_Idle = $0;
  state_Initializing = $1;
  state_Sweeping = $2;
  state_Done = $3;
  state_Error = $ - 1;

type
  TIBSweepThread = class(TThread)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure DoSweep;
  public
    { Public declarations }
    DatabaseName: string; // Fully qualifyed name to db
    DatabaseUsername: string; // Username
    DatabasePassword: string; // Password
    Processing: Boolean; // True while processing
    ResultState: Integer; // See state_xxxx constants
    ProcessTime: Cardinal; // Milliseconds of the sweep

    property Terminated; // Make the Terminated published

    constructor Create(CreateSuspended: Boolean); virtual;
    procedure Execute; override;
    procedure WaitForAndSleep;
  published
    { Published declarations }
  end;

implementation

{ TIBSweepThread }

///////////////////////////////////////////////////////////////////////////////
//
// Threads Constructor. Allocated objects, and initializes some
// variables to the default states.
//
// Also sets the Priority and FreeOnTreminate conditions.
//
///////////////////////////////////////////////////////////////////////////////

constructor TIBSweepThread.Create(CreateSuspended: Boolean);
begin
  { Override user parameter }
  inherited Create(True);
  { Default parameters }
  FreeOnTerminate := False;
  Priority := tpLower;
  { Set variables }
  Processing := False;
  ResultState := state_Idle;
end;

///////////////////////////////////////////////////////////////////////////////
//
// Threads execute loop. Jumps to the DoWork() procedure every 250 ms
//
///////////////////////////////////////////////////////////////////////////////

procedure TIBSweepThread.Execute;
begin
  try
    { Perform the Sweep }
    DoSweep;
  except
    on E: Exception do
      ; // TODO: Execption logging
  end;
  { Signal terminated }
  Terminate;
end;

///////////////////////////////////////////////////////////////////////////////
//
// Waits for the Thread to finish. Same as WaitFor, but does not take
// 100% CPU time while waiting ...
//
///////////////////////////////////////////////////////////////////////////////

procedure TIBSweepThread.WaitForAndSleep;
var
  H: THandle;
  D: DWord;
begin
  { Get Handle }
  H := Handle;
  { Wait for it to terminate }
  repeat
    D := WaitForSingleObject(H, 1);
    { System Slizes }
    SleepEx(1, True);
  until (Terminated) or ((D <> WAIT_TIMEOUT) and (D <> WAIT_OBJECT_0));
end;

///////////////////////////////////////////////////////////////////////////////
//
// Makes a sweep of the database specifyed in the properties.
//
///////////////////////////////////////////////////////////////////////////////

procedure TIBSweepThread.DoSweep;
var
  IBSweep: TIBValidationService;
  SrvAddr: string;
  DBName: string;
begin
  try
    { Set Start Time }
    ProcessTime := GetTickCount;
    { Extract SrvAddr and DBName from DatabaseName }
    SrvAddr := DatabaseName;
    { Correct if Local machine }
    if Pos(':', SrvAddr) <> 0 then
    begin
      Delete(SrvAddr, Pos(':', SrvAddr), Length(SrvAddr));
      DBName := DatabaseName;
      Delete(DBName, 1, Pos(':', DBName));
    end
    else
    begin
      { Must be localhost since Server Address is missing }
      SrvAddr := '127.0.0.1';
      DBName := DatabaseName;
    end;
    { Set Flags }
    Processing := True;
    ResultState := state_Initializing;
    try
      { Create IBValidationService }
      IBSweep := TIBValidationService.Create(nil);
      IBSweep.Protocol := TCP;
      IBSweep.LoginPrompt := False;
      IBSweep.Params.Values['user_name'] := DatabaseUsername;
      IBSweep.Params.Values['password'] := DatabasePassword;
      IBSweep.ServerName := SrvAddr;
      IBSweep.DatabaseName := DBName;
      IBSweep.Active := True;
      IBSweep.Options := [SweepDB];
      try
        { Start the service }
        IBSweep.ServiceStart;
        { Set state }
        ResultState := state_Sweeping;
        { Get the Report Lines - No lines in Sweeping but needs to be done }
        while not IBSweep.Eof do
        begin
          IBSweep.GetNextLine;
          { Wait a bit }
          Sleep(1);
        end;
      finally
        { Deactive Service }
        IBSweep.Active := False;
      end;
      { Set State to OK }
      ResultState := state_Done;
    except
      on E: Exception do
      begin
        { Set State to OK }
        ResultState := state_Error;
      end;
    end
  finally
    { Calculate Process Time }
    ProcessTime := GetTickCount - ProcessTime;
    { Free objects }
    if Assigned(IBSweep) then
    begin
      if IBSweep.Active then
        IBSweep.Active := False;
      IBSweep.Free;
      IBSweep := nil;
    end;
    { Set flag }
    Processing := False;
  end;
end;

end.

Checking if a URL is valid

Problem/Question/Abstract:

You are given a list of URLs, which may or may not include the file name- eg www.msn.com instead of www.msn.com/default.asp. You want to check them automatically. The function provided does this.

Answer:

This function will check the url with or without a file. The only precondition is that you must be online.

URLs can be given with or without the http:/ prefix - its adds the http:// prefix if absent- this is vital for the internetOpenUrl function which also supports FTP:// and gopher://

I am checking the return code for '200' or '302' - redirects but you may wish to check for other codes. Just modify the result := line to accomodate these codes.

uses wininet;

function CheckUrl(url: string): boolean;
var
  hSession, hfile, hRequest: hInternet;
  dwindex, dwcodelen: dword;
  dwcode: array[1..20] of char;
  res: pchar;
begin
  if pos('http://', lowercase(url)) = 0 then
    url := 'http://' + url;
  Result := false;
  hSession := InternetOpen('InetURL:/1.0',
    INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if assigned(hsession) then
  begin
    hfile := InternetOpenUrl(
      hsession,
      pchar(url),
      nil,
      0,
      INTERNET_FLAG_RELOAD,
      0);
    dwIndex := 0;
    dwCodeLen := 10;
    HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,
      @dwcode, dwcodeLen, dwIndex);
    res := pchar(@dwcode);
    result := (res = '200') or (res = '302');
    if assigned(hfile) then
      InternetCloseHandle(hfile);
    InternetCloseHandle(hsession);
  end;

end;

Get the Password of the screensaver

Problem/Question/Abstract:

How to get the Password of the screensaver?

Answer:

//this is a small function which give the password of the screensaver!!

function GetScrPass: string;
var
  ScrnSvrPss: string;
  reg: TRegistry;
  buf: array[0..256] of char;
  length: word;
  a: byte;
  asdec: byte;
  password: string[128];
const // Decrypts the screen saver password from the registry
  xorwert: array[1..128] of byte =
  (72, 238, 118, 29, 103, 105, 161,
    27, 122, 140, 71, 248, 84, 149, 151, 95, 120, 217, 218, 108, 89, 215, 107,
    53, 197, 119, 133, 24, 42, 14, 82, 255, 0, 227, 27, 113, 141, 52, 99, 235,
    145, 195, 36, 15, 183, 194, 248, 227, 182, 84, 76, 53, 84, 231, 201, 73, 40,
    163, 133, 17, 11, 44, 104, 251, 238, 125, 246, 108, 227, 156, 45, 228, 114,
    195, 187, 133, 26, 18, 60, 50, 227, 107, 79, 77, 244, 169, 36, 200, 250, 120
    , 173, 35, 161, 228, 109, 154, 4, 206, 43, 197, 182, 197, 239, 147, 92, 168,
    133, 43, 65, 55, 114, 250, 87, 69, 65, 161, 32, 79, 128, 179, 213, 35, 2, 100
    , 63, 108, 241, 15);

begin
  password := '';

  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  Reg.OpenKey('Control PanelDesktop', FALSE);
  Reg.ReadBinaryData('ScreenSave_Data', buf, sizeof(buf));

  length := (Reg.GetDataSize('ScreenSave_Data') - 1) shr 1;

  if Reg.ReadBool('ScreenSaveUsePassword') then
    for a := 1 to length do
    begin
      asdec := StrToInt('$' + buf[(a shl 1) - 2] + buf[(a shl 1) - 1]);
      password := concat(password, Chr(asdec xor xorwert[a]));
    end
  else
    password := 'There was an error getting the password.';
  reg.free;
  ScrnSvrPss := password;

  //sleep(1000);
  result := ScrnSvrPss;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  edit1.text := GetScrPass;
end;

Validate an object

Problem/Question/Abstract:

How do you check if an object fits your condition and that of the compiler ?

Answer:

From time to time you want to be sure, if an object fits your conditions like naming conventions, robustness or you want the compiler find  no further errors. The  function checkOBJ determines whether a passed object, with a boolean returned from the function, represents an error condition.

function TTrans.checkOBJ(aObject: TObject): boolean;
var
  str: string;
  i: integer;
begin
  result := false;
  if aObject = nil then
    exit;
  try
    str := ansiUppercase(aObject.classname);
    if str = '' then
      exit;
    for i := 1 to length(str) do
      if not (str[i] in ['0'..'9', 'A'..'Z', '_']) then
        exit;
    aObject.classType;
    if aObject.InstanceSize < 1 then
      exit;
    aObject.ClassnameIs('TObject');
    result := aObject.ClassNameIs(aObject.Classname);
  except
    exit;
  end;
end;

You can call it then with an assert, so you get during the development a bit of quality assurance ;).

accObj := TAccount.createAccount(FCustNo, std_account);
assert(aTrans.checkOBJ(accObj), 'bad condition with OBJ'); //trans

Use Assert as a debugging check to test that conditions assumed to be true are never violated. Assert provides an opportunity to intercept an unexpected condition and halt a program rather than allow execution to continue under unanticipated conditions.

The 5 Relationships between Classes

Problem/Question/Abstract:

How do we find related classes with the right UML-Notation, means which relationship belongs to which code ?

Answer:

Despite the fact that several advanced languages have come out of the OO Revolution, such as Java, C++, OP  a lot of people are still designing their code with minimal design in mind.
UML was formed in attempt to unify the best (or most popular in this case) modelling methods in Object-Oriented Analysis and Design. Let's focus on the Class Diagram and learn the 5 Relationships with OP (ObjectPascal).
So good up design will actually shorten the development cycle, give you an idea of the resources you need, and how to end the project.
The 5 Relationships are:

Inheritance
Association
Aggregation
Composition
Dependency
Realisation new UML 1.4  

The Class Diagram is the static architectural representation of your software and capable with a CASE-Tool to generate Code.  It allows you to see the overall object structure of the system.
Let's start with the Inheritance (Generalization). All Relations are represented by Fig.1, (download cd_busobj.tif) but also by Code:

1) Inheritance is represented by a triangle and TBusinessObj is a subclass of TDataModule1, inheriting all of the members (Attributes and Operations) of the superclass.

TBusinessObj = class(TDataModule1)
private
  function calcSalary(salary: double): Double;
  procedure changeGrade(amount: integer);
public
  constructor Create(aOwner: TComponent); override;
  destructor destroy; override;
  procedure changeSalary(amount: double);
  function getFullName: string;
  function getOldSalary: Double;
  function open_QueryAll: Boolean;
  function open_QuerySalary(qryID: integer): Boolean;
end;
  
2) Association is represented by a line, means a relationship at runtime. In Fig.1 seen by from TDataToXML. Association is not a tight coupling between objects, you call it and free it at runtime with local instances:

procedure TForm1.btnToXMLClick(Sender: TObject);
begin
  with TDataToXML.create do
  begin
    try
      dataSetToXML(datEmployee.query1, 'salaryXport.xml');
    finally
      free;
    end
  end;
end;

3) Aggregation is a whole-part relationship. A TDataModule1 has Queries from TQuery, so the white diamond is positioned near the container to represent the Queries are the parts of the DataModule. It means also a relationship at designtime, Query1 is a steady member of TDataModule1:

TDataModule1 = class(TDataModule)
  Database1: TDatabase;
  DataSource1: TDataSource;
  Query1: TQuery;
public
  procedure loadTree(myTree: TTreeView; fromFile: string);
  procedure storeTree(myTree: TTreeView; toFile: string);
end;

4) Composition is a stronger form of Aggregation. Composition is represented by a black diamond. For example in the VCL you can often find constructs like this: memo1.lines.add, so memo1 is TMemo and lines is TStrings. Means in our example if a class TForm1 has an instance and needs another instance too, there we have a composition:

procedure TForm1.fillEmployees;
begin
  with datEmployee.dataSource1 do
  begin
    while not dataSet.EOF do
    begin
      cmxEmployee.items.add(intToStr(dataSet.fieldValues['EMP_NO']));
      dataSet.next;
    end;
  end;
end;

5) Dependency is a dotted arrow and not shown in our diagram.  It is used to show that one UML Element depends upon another. Dependencies can be used to describe the relationship not only between classes, also packages, or components. In a Class Diagram you find it for ex. that one class depends on a type of another class and the class is part of a Library, like the VCL. In our case TDataModule1 depends upon TTreeView (TreeView uses ComCtrls). But it's TForm1 which really depends on TTreeView, cause the instance TTreeView1 is a member of the Form:

TForm1 = class(TForm)
TreeView1: TTreeView;

procedure TDataModule1.storeTree(myTree: TTreeView; toFile: string);
begin
  with TFileStream.create(toFile, fmcreate) do
  begin
    try
      writeComponent(myTree);
    finally
      free;
    end;
  end
end;

6) Interface support is like inheritance but there is a strict interface-specification and a class which supports the interface, marked in UML like a lollipop in the diagram or a dotted arrow from implement to interface:

IIncomeInt = interface(IUnknown)
  ['{DBB42A04-E60F-41EC-870A-314D68B6913C}']
  function GetIncome(const aNetto: Currency): Currency; stdcall;
  function GetRate: Real; stdcall;
  {.....}
  TIncomeRealSuper = class(TInterfacedObject, IIncomeInt)
  private
    FRate: Real;
    function Power(X: Real; Y: Integer): Real;
  protected
    function GetRate: Real;
  public
    constructor Create;

Interfaces works the same way in CLX or Kylix, as long as you don't use IDispatch from COM! So you don't need a MS-specific library to use interfaces.


Component Download: http://max.kleiner.com/download/businessobj.zip

Restrict the mouse movement to form

Problem/Question/Abstract:

Using the Windows API function ClipCursor, it is possible to restrict the movement of the mouse to a specific rectangular region on the screen.

Answer:

//restrict the mouse mouvement to form and release
//this restriction after a click on the form

procedure TForm1.FormCreate(Sender: TObject);
var
  r: TRect;
begin
  //it would be good idea to move the
  //mouse inside the form before restriction
  r := BoundsRect;
  ClipCursor(@R);
end;

procedure TForm1.FormClick(Sender: TObject);
begin
  //always be sure to release the cursor
  ClipCursor(nil);
end;

Use forms declared in DLL by an executable

Problem/Question/Abstract:

How to use forms declared in DLL by an executable?

Answer:

In the example that follows the exe only sees a totally "virtual abstract" interface to the object as is being exported from the dll but it still can create the object and use it. Of course the exe can not see or execute any methods declared in the exe but that is the whole purpose of implementing them in a custom dll to begin with.

// Example code:

program Dlloader;

uses
  Sharemem,
  Forms,
  exeunit1 in 'exeunit1.pas' {Form1},
  DllIntfu in 'DllIntfu.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

//--------------------------

unit DllIntfu;

interface

type
  TDllobject = class
  protected
    function Get_UserName: string; virtual; abstract;
    procedure Set_UserName(Value: string); virtual; abstract;
  public
    property UserName: string read Get_UserName write Set_UserName;
  end;
  TDllobjectClass = class of TDllobject;

implementation

end.

//---------------------------

unit exeunit1;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TDllfunc = function: TDllobjectClass;
  stdcall;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: DWORD;
  fHandle: THandle;
  fDllfunc: TDllfunc;
  fDllobject: TDllobject;
  fUserName: string;
begin
  fHandle := LoadLibrary('UserName.dll');
  if (fHandle <> 0) then
  begin
    @fDllfunc := GetProcAddress(fHandle, 'Dllfunc');
    if Assigned(@fDllfunc) then
    begin
      i := 255;
      SetLength(fUserName, i);
      GetUserName(PChar(fUserName), i);
      fUserName := StrPas(PChar(fUserName));
      fDllobject := fDllfunc.Create;
      fDllobject.UserName := fUserName;
      ShowMessage(fDllobject.UserName);
      fDllobject.Free;
    end;
    FreeLibrary(fHandle);
  end;
end;

end.

//-------------------------------

library UserName;

uses
  Sharemem,
  Sysutils,
  DllIntfu;

type
  TCustomDllobject = class(TDllobject)
  private
    fUserName: string;
    function Getfilecount: Integer;
  protected
    function Get_UserName: string; override;
    procedure Set_UserName(Value: string); override;
  end;

  TCustomDllobjectclass = class of TCustomDllobject;

function TCustomDllobject.Getfilecount: Integer;
var
  doserr: Integer;
  fsrch: TSearchRec;
begin
  Result := 0;
  doserr := FindFirst('*.*', faanyfile, fsrch);
  if (doserr = 0) then
  begin
    while (doserr = 0) do
    begin
      if (fsrch.attr and faDirectory) = 0 then
        Inc(Result);
      doserr := findnext(fsrch);
    end;
    FindClose(fsrch);
  end;
end;

function TCustomDllobject.Get_UserName: string;
begin
  Result := 'You signed on as ''' + fUserName + '''' +
    ' and there ' + IntToStr(Getfilecount) +
    ' files in this directory.';
end;

procedure TCustomDllobject.Set_UserName(Value: string);
begin
  fUserName := Value;
end;

function Dllfunc: TCustomDllobjectClass; stdcall;
begin
  Result := TCustomDllobject; // class type only
end;

exports
  Dllfunc name 'Dllfunc';

begin
end.

Print a TListView

Problem/Question/Abstract:

I have a TListView component on my form. When I call listview1.paintto(printer.handle,30,30), where listview1 is of type TListView, the content of the grid is printed like expected, but the column headings are not printed. Is this a (windows?) bug or is it just me using the PaintTo the wrong way?

Answer:

It is no bug, just a problem caused by the way PaintTo works. Basically it sends a WM_PAINT message to a control with a canvas handle in wparam. This tells the control to paint its client area to the canvas. The problem in your case is that the listview header is not part of the listviews client area, it is an embedded header control. So you need to send that one a paint message as well. Unfortunately it has no VCL wrapper control, so PaintTo cannot be used. There is a little-known Windows message that can be used as alternative to WM_PAINT. The problem is that not all controls seem to implement it. But TListview does:

procedure TForm1.Button1Click(Sender: TObject);
var
  bmp: TBitmap;
begin
  bmp := Tbitmap.Create;
  try
    bmp.width := listview1.width;
    bmp.height := listview1.height;
    with bmp.canvas do
    begin
      Lock;
      try
        listview1.perform(WM_PRINT, handle, PRF_CHILDREN or PRF_CLIENT or
          PRF_NONCLIENT or PRF_ERASEBKGND);
      finally
        Unlock
      end;
      image1.picture.bitmap := bmp;
    end;
  finally
    bmp.free
  end;
end;

Knowing Run-Time verses Design-Time mode in an Active Form

Problem/Question/Abstract:

How to find out if your ActiveX control is running in Design mode or Run mode

Answer:

Every now and then an ActiveForm developer will want to add a feature to an ActiveX control that only shows up in either Design-Time or Run-Time (splash screens and nag screens are an example). (Background: Design-Time is when a control is applied to a form in the Visual Basic environment; Run-Time is when the control is running inside of an executable).  If you are using TActiveXControl as you&#8217;re base object, you get this for free.  If you are using TActiveForm you have to work for the information.

The property we need is UserMode.  If this property is True we are in Run-Time mode; if False we are in Design-Time mode. UserMode is one of the AmbientProperties that a control&#8217;s container is supposed to provide.  Delphi even supplies an interface call IAmbientDispatch in AxCtrls for retrieving the ambient properties.  

To get it: Your ActiveForm has a property called ActiveFormControl.ClientSite.  This property is set sometime before your control's OnShow event (ClientSite will not be set in the constructor or the initialize procedures).  Cast ClientSite to an IAmbientDispatch (found in AxCtrls), then get the UserMode property. (see code below)

procedure TDesignCtrl.HandleOnShow(Sender: TObject);
var
  b: Boolean;
  pIAmbient: IAmbientDispatch;
begin
  pIAmbient := Self.ActiveFormControl.ClientSite as IAmbientDispatch;
  b := pIAmbient.UserMode;

  if b then
    ShowMessage('is in runtime mode')
  else
    ShowMessage('is in design mode');
end;

There are other properties in the IAmbientDispatch interface that could also be useful to a control writer so feel free to experiment.

Managing a lot of Forms

Problem/Question/Abstract:

How do you controll hundreds of forms by number in a main unit ?

Answer:

Suppose you have a call from a dear developer that had about 100 forms that he have to create and run. So you tell him, create and run it by number in, here's a solution to this problem...

The following part is to be placed on the main form's unit, maybe a frmController unit and the purpose is to have a couple of arrays that are referenced by number and then accessible to manipulate:

const
  maxForms = 100;

var
  frmController: TForm1
  frmArray: array[1..maxForms] of TForm;
  frmRefArray: array[1..maxForms] of TFormClass;

implementation
uses Unit7; // and all of the units

procedure TForm1.btnfrmController(sender: TObject);
begin
  ... // iterating or indexing as you like
  frmArray[7] := frmRefArray[7].create(self);
  frmArray[7].showModal; // whatever you need
  frmArray[7].free;
end;

The next step is, each form must register itself in the array of the controller or main form unit. This can be done at load time or runtime, let's get straight to the implementation part:

unit Unit7;

implementation

uses frmControllerU;

procedure TForm7.FormCreate(sender: TObject);
frmArray[7] := self;
end;

initialization
  frmRefArray[7] := TForm7 //hard coded

The last part means that you must tell the array which class has to be associated with which array element. So you get by ObjectPascal the classReference, another way that this can be done is by using an extra unit where all of the form's information is centralized and easier to maintain, but the idea remains the same.

ps: If the form is already instantiated, then you find it through the TScreen object (don't scream use TScreen ;):

for i := 0 to screen.FormCount - 1 do
  if screen.forms[i].className = 'TForm7' then {... }

Export functions and methods from DLL

Problem/Question/Abstract:

Some time ago I have created a program using Delphi3. Now I want to adapt it to Delphi7. The problem is that creating the program I have used component (TComponent descendent) without source files and I can not install it into Delphi7.

Actually I use only one function and one method (event) which returns the progress. I thought maybe I could add that component into DLL using D3 and use this DLL with D7. The function of the component exports successfully from DLL but how to export the Method (Event) of it?

Answer:

Well, if there is no D7 version of this component a DLL build with D3 is indeed the best solution to your problem. It would have helped if you had posted the declarations of the function you need to call and the event you want to handle, though. Without that at hand i can only give you some general guidance.

What you need to do is to build a set of exported functions for the DLL that gives you access to the components functionality. Since DLL and host EXE are build with different Delphi versions they cannot safely share a memory manager via the ShareMem unit, so you cannot pass data types like AnsiString to the DLL functions or receive such parameters in the event handler. You have to write the DLL interface like a set of Windows API methods, using only types that do not require a shared memory manager. Since the original component may not fit this requirements you need a layer of insulation between the DLLs exported functions and the component, best implemented as a class since you will need an object method to handle the components event anyway.

There is also the question of how to manage the lifetime of the DLL component.You can create it easily the first time the DLLs exported function is called to get the component do some work. But where to destroy it again? The usage pattern your post implies is not synchronous, the component seems to be doing something in a secondary thread after its mystery method has been called, delivering progress events while at work. The best option seems to be to provide another exported function the host EXE can call to get the DLL to destroy the component when it is no longer needed.

OK, let's try to code a DLL interface as a wrapper for this hypothetical component:

type
  TProgressEvent = procedure(PercentDone: Integer) of object;
  TMysteryComponent = class(TComponent)
    {....}
  public
    function ProcessData(const Data: string): Boolean;
  published
    property OnProgress: TProgressEvent
      read FProgressEvent write FProgressEvent;
  end;
    
The import unit for the DLL used in your D7 program would then look like this:

unit MysteryComponentWrapper;

interface

type
  TWrapperProgressEvent = procedure(PercentDone: Integer) of object;

function WrapperProcessData(Data: Pchar;
  ProgressCallback: TWrapperProgressEvent): Boolean;

function DestroyWrapper: Boolean;

implementation

function WrapperProcessData(Data: Pchar;
  ProgressCallback: TWrapperProgressEvent): Boolean;
  external 'MystComp.DLL';

function DestroyWrapper: Boolean;
  external 'MystComp.DLL';

end.

The DLL project file would look like this:

library MystComp;

uses
  WrapperU;

exports
  WrapperProcessData, DestroyWrapper;
begin
end.

The meat is in the WrapperU unit:

unit WrapperU;

interface
type
  TWrapperProgressEvent = procedure(PercentDone: Integer) of object;

function WrapperProcessData(Data: Pchar;
  ProgressCallback: TWrapperProgressEvent): Boolean;

function DestroyWrapper: Boolean;

implementation

uses Sysutils, MysteryComponentU;

type
  TWrapper = class
  private
    FProgressEvent: TWrapperProgressEvent;
    FMysteryComponent: TMysteryComponent;

    procedure ProgressHandler(PercentDone: Integer);
  public
    constructor Create;
    destructor Destroy; override;

    function ProcessData(Data: Pchar;
      ProgressCallback: TWrapperProgressEvent): Boolean;
  end;

var
  Wrapper: TWrapper; //starts out as Nil

function WrapperProcessData(Data: Pchar;
  ProgressCallback: TWrapperProgressEvent): Boolean;
begin
  try
    if not Assigned(Wrapper) then
      Wrapper := TWrapper.Create;
    Result := Wrapper.ProcessData(Data, ProgressCallback);
  except
    Result := false;
  end;
end;

function DestroyWrapper: Boolean;
begin
  Wrapper.Free;
  Wrapper := nil;
end;

procedure TWrapper.ProgressHandler(PercentDone: Integer);
begin
  if Assigned(FProgressEvent) then
    FProgressEvent(PercentDone);
end.

constructor TWrapper.Create;
begin
  inherited;
  FMysteryComponent := TMysteryComponent.Create(nil);
  FMysteryComponent.OnProgress := ProgressHandler;
end;

destructor TWrapper.Destroy;
begin
  FMysteryComponent.Free;
  inherited;
end;

function TWrapper.ProcessData(Data: Pchar;
  ProgressCallback: TWrapperProgressEvent): Boolean;
begin
  FProgressEvent := ProgressCallback;
  Result := FMysteryComponent.ProcessData(Data);
end;

end.

Inheritance - Creating Sub/Super Classes - A Guideline...

Problem/Question/Abstract:

When can we create sub/super classes in an Object Oriented Design?

Answer:

As every Object Pascal developer knows, inheritance is one of the fundamental concepts in Object Oriented Design. I&#8217;m not going to give you any explanation on what Inheritance is since everybody knows the definition already. Instead, I'm going to give you some of the tips in designing classes in the early stages of Object Oriented Design.

In any project development, the analysis and design phases will be given importance in the initial stage.  In Object Oriented Design/Visual Modeling, once the team starts collecting information regarding the project, the team will identify the objects involved in each of the activities.

At one stage, the team will have some sample classes for those objects identified. As the design stage matures, there would be more and more classes coming. Sometimes, you may need to inherit a new class from an existing one or you may need to group two classes into one. At this time, you may use the following concepts/techniques to create a sub/super class from existing classes:

What is a Sub Class and Super Class

It's a class inherited/derived from another class. The new class(sub-class) will have all the properties/methods and events of the parent class(from which it inherited) and can have additional properties specific to this sub-class. The parent class is called Super Class.

Let me explain this concept with an example.

Let us suppose we have a class called TCitizen.

The structure of TCitizen is something like this:

TCitizen = class
  SocialSecurityNo: string;
  Name: string;
  Age: integer;
  Street: string;
  City: string;
  State: string;
  Zip: integer;
  {..................
  ..................etc., }
end;

The above attributes are some of the common attributes you can have for a Citizen. This citizen could be anybody from a small child to an old man in a country.

Let us suppose that we have, in our analysis, some Veterans information also. Veterans are people who were being in Army and/or some distinguished government services and retired now. Those Veterans are also part of normal citizens but they would have some special privileges. In this case, we can use the existing TCitizen class by adding the special privileges attributes for a Veteran but that would not be a better design. In this case, we can call this Veteran as a SPECIALIZED Citizen. So we can create a new SUB CLASS derived from the TCitizen, called TVeteranCitizen.

The TVeteranCitizen class may look like something like this:

TVeteranCitizen = class(TCitizen)
  NoOfYearsOfService: integer;
  Rewards: string;
  Ranks: string;
  DateRetired: TDateTime;
  {.........................................
  ......................................etc., }
end;

GENERALIZATION: Creating Super Classes

Let me explain this also thru some sample classes.

Let us suppose we are designing a library system and we identified two classes TStudent, containing student information, and TProfessor, containing professor information, among other classes. We take these two classes for our discussion.

The structure of those two classes would be as follows:

TStudent = class
  StudentID: string;
  Name: string;
  Age: string;
  Grade: string;
  {........................
  .....................etc., }
end;

TProfessor = class
  ProfID: string;
  Name: string;
  Age: string;
  {....................
  ................etc., }
end;

The system will allow both the students and professors to login using their student and professor ids and do the library related activities. The system will verify the student and professor ids at the time of login.

Here we can GENERALIZE an information pertaining to both the classes as long as they both agree in their structure and type. I&#8217;m talking about the two attributes StudentID in TStudent and ProfID in TProfessor. In this case, they both are of same type: String. The second thing is that they should be both of the same structure/size string. If StudentID is of seven charactors length and ProfID is of four charactors length, then we cannot generalize this info.

As long as they both agree on those two things, we can generalize.

They both serve as a way to login to the system after verification. So we can GENERALIZE this information and create a SUPER CLASS with a name TUser and inherit both TStudent and TProfessor from TUser.

Although this seems to be a simple issue, I just would like to share this with our Delphi Community.

Reducing Source Code Complexity in your application

Problem/Question/Abstract:

Have you ever written an application where things have to know when things happen, such as when an object gets freed then you need to update some UI screen or remove some depency. Or in the case of a paint program where when a mode change requires a cursor change, buttons to enable or disable or push down... if something gets deleted then you have to do this and that etc... I have a solution that will keep your code clean of linking code.

Answer:

There are times when you write an application that turns into a linking nightmare when your system needs to react to certain conditions.  Examples are Mode changing in a paint program requires cursor changes, an object being updated needs to update some UI element or disable and enable controls, when an object gets freed you need to remove dependencies.  In other words there are side effects that you need to happen as a result of something changing in your application. Coding these side effects can produce some nasty code that is like a big spider web.

The solution to the problem is to use a "Message Center". I have created a easy to use MessageCenter class that uses the built in messaging capablity already built into TObject.  Source code is at the end of this artical.

1. Concept of the message center

The concept is simple, you have a central "hub" that receives maybe all actions that happen in your program.  Certain parts of your program need to change when these events happen.  Instead of hard coding these "reactions" into your code, you send the message of the event to the message center in a record structure.  Anything that needs to react or change based on the event is registered with and notified by the MessageCenter.

2. Example Implementation

This app is an image editor where you can have multiple images opened at once.
Each Image is opened in a Form class of TForm_ImageEdit.
A graphical list of buttons are listed at the top of the main form, there is one button per opened image and a picture of the image is drawn on the surface of the button.  Users can click the button and active the form for that image.

The rule of the system is
A button should be added when a new form is added.
The button should remove when the form is removed.
The button should push down when the editor form becomes active.

First define the MessageID and the record for the message.

const
  MID_ImageEdit = 14936;

type
  TMID_ImageEdit = packed record
    MessageID: Cardinal; // This is required field for Dispatching
    Action: (aDestroyed, aActivated);
    ImageEdit: TForm_ImageEdit;
  end;

Then within the TForm_ImageEdit Broadcast the messages...

procedure TForm_ImageEdit.FormDestroy(Sender: TObject);
var
  M: TMID_ImageEdit;
begin
  with M do
  begin
    M.MessageID := MID_ImageEdit;
    M.Action := aClosed;
    M.ImageEdit := Self;
  end;
  GetMessageCenter.BroadcastMessage(Self, M);
end;

procedure TForm_ImageEdit.FormActivate(Sender: TObject);
var
  M: TMID_ImageEdit;
begin
  with M do
  begin
    M.MessageID := MID_ImageEdit;
    M.Action := aActivated;
    M.ImageEdit := Self;
  end;
  GetMessageCenter.BroadcastMessage(Self, M);
end;

Now to edit the main form

At some point in your main form when you create the Image Editor, add this code after creation:

F := TForm_ImageEdit.Create(Self);
// Listen to messages
GetMessageCenter.AttachListner(Self, F);

// Next few lines will add the button for the new form at the top of the main window.
{.
.
. }

This way the Main form will receive messages from the ImageEditor window.

So now Add this MessageHandler to your main form:
Create this method to receive messages of type MID_IMageEdit:

procedure ImageEditorWindowChanged(var Msg: TMID_ImageEdit); message MID_ImageEdit;

And implement it in this way

procedure TForm_NMLDA.ImageEditorWindowChanged(var Msg: TMID_ImageEdit);
begin
  case Msg.Action of
    aDestroyed:
      begin
        ImageEditorClosed(Msg.ImageEdit);
        GetMessageCenter.DetachListner(Self, Msg.ImageEdit);
      end;
    aActivated: EditorFocused(Msg.ImageEdit);
  end;
end;

ImageEditorClosed method will remove the button from the main form EditorFocused will push down the button associated with the ImageEditor.

Thats all, you have low coupling and you may attach as many listners as you like.

This concept has a lot of potential and it will make your complex apps very simple and maintainable.

Here is the code:

unit MessageCenter;
{
  William Egge public@eggcentric.com
  Created Feb - 28, 2002
  You can modify this code however you wish and use it in commercial apps.  But
    it would be cool if you told me if you decided to use this code in an app.

  The goal is to provide an easy way to handle notifications between objects
  in your system without messy coding.  The goal was to keep coding to a minimum
  to accomplish this. That is why I chose to use Delphi's built in
  Message dispatching.
  This unit/class is intended to be a central spot for messages to get dispatched,
    every object in the system can use the global GetMessageCenter function.
  You may also create your own isolated MessageCenter by creating your own
    instance of TMessageCenter.. for example if you had a large subsystem and
    you feel it would be more effecient to have its own message center.

  The goal is to capture messages from certain "Source" objects.

  Doc:
    procedure BroadcastMessage(MessageSource: TObject; var Message);
      The message "Message" will be sent to all objects who called AttachListner
      for the MessageSource.
      If no objects have ever called AttachListner then nothing will happen and
      the code will not blow up :-).  Notice that there is no registration for
      a MessageSource, this is because the MessageSource registration happens
      automatically when a listner registers itself for a sender.
      (keeping external code simpler)

    procedure AttachListner(Listner, MessageSource: TObject);
      This simply tells the MessageCenter that you want to receive messages from
      MessageSource.

    procedure DetachListner(Listner, MessageSource: TObject);
      This removes the Listner so it does not receive messages from MessageSource.

  Technique for usage with interfaces:
    If your program is interface based then its not possible to pass a
    MessageSource but it IS possible to pass an object listner if it is being
    done from within the object wanting to "listen" (using "self").
    To solve the problem of not being able to pass a MessageSource, you can
    add 2 methods to your Sender interface definition,
    AttachListner(Listner: TObject) and DetachListner(Listner: TObject).
    Internally within those methods your interfaced object can call the
    MessageCenter and pass its object pointer "Self".

  Info:
    Performance and speed were #1 so...

    MessageSources are sorted and are searched using a binary search so that
    a higher number of MessageSources should not really effect runtime performance.
    The only performance penalty for this is on adding a new MessageSource because
    it has to do an insert rather than an add, this causes all memory to be shifted
    to make room for the new element.  The benifit is fast message dispatching.

    There is no check for duplicate MesssageListners per Sender, this would have
    slowed things down and this coding is usefull only when you have bugs.  And
    hoping you prevent bugs, you do not have to pay for this penalty when your
    code has no bugs.
}

interface
uses
  Classes, SysUtils;

type
  TMessageCenter = class
  private
    FSenders: TList;
    FBroadcastBuffers: TList;
    function FindSenderList(Sender: TObject; var Index: Integer): TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BroadcastMessage(MessageSource: TObject; var Message);
    procedure AttachListner(Listner, MessageSource: TObject);
    procedure DetachListner(Listner, MessageSource: TObject);
  end;

  // Shared for the entire application
function GetMessageCenter: TMessageCenter;

implementation
var
  GMessageCenter: TMessageCenter;
  ShuttingDown: Boolean = False;

function GetMessageCenter: TMessageCenter;
begin
  if GMessageCenter = nil then
  begin
    if ShuttingDown then
      raise
        Exception.Create('Shutting down, do not call GetMessageCenter during shutdown.');
    GMessageCenter := TMessageCenter.Create;
  end;

  Result := GMessageCenter;
end;

{ TMessageCenter }

procedure TMessageCenter.AttachListner(Listner, MessageSource: TObject);
var
  L: TList;
  Index: Integer;
begin
  L := FindSenderList(MessageSource, Index);
  if L = nil then
  begin
    L := TList.Create;
    L.Add(MessageSource);
    L.Add(Listner);
    FSenders.Insert(Index, L);
  end
  else
    L.Add(Listner);
end;

procedure TMessageCenter.BroadcastMessage(MessageSource: TObject; var Message);
var
  L, Buffer: TList;
  I: Integer;
  Index: Integer;
  Obj: TObject;
begin
  L := FindSenderList(MessageSource, Index);
  if L <> nil then
  begin
    // Use a buffer because objects may detach or add during the broadcast
    // Broadcast can be recursive.  Only broadcast to objects that existed
    // before the broadcast and not new added ones.  But do not broadcast to
    // objects that are deleted during a broadcast.
    Buffer := TList.Create;
    try
      FBroadcastBuffers.Add(Buffer);
      try
        for I := 0 to L.Count - 1 do
          Buffer.Add(L[I]);

        // skip 1st element because it is the MessageSender
        for I := 1 to Buffer.Count - 1 do
        begin
          Obj := Buffer[I];
          // Check for nil because items in the buffer are set to nil when they are removed
          if Obj <> nil then
            Obj.Dispatch(Message);
        end;
      finally
        FBroadcastBuffers.Delete(FBroadcastBuffers.Count - 1);
      end;
    finally
      Buffer.Free;
    end;
  end;
end;

constructor TMessageCenter.Create;
begin
  inherited;
  FSenders := TList.Create;
  FBroadcastBuffers := TList.Create;
end;

destructor TMessageCenter.Destroy;
var
  I: Integer;
begin
  for I := 0 to FSenders.Count - 1 do
    TList(FSenders[I]).Free;
  FSenders.Free;
  FBroadcastBuffers.Free;
  inherited;
end;

procedure TMessageCenter.DetachListner(Listner, MessageSource: TObject);
var
  L: TList;
  I, J: Integer;
  Index: Integer;
begin
  L := FindSenderList(MessageSource, Index);
  if L <> nil then
  begin
    for I := L.Count - 1 downto 1 do
      if L[I] = Listner then
        L.Delete(I);

    if L.Count = 1 then
    begin
      FSenders.Remove(L);
      L.Free;
    end;

    // Remove from Broadcast buffers
    for I := 0 to FBroadcastBuffers.Count - 1 do
    begin
      L := FBroadcastBuffers[I];
      if L[0] = MessageSource then
        for J := 1 to L.Count - 1 do
          if L[J] = Listner then
            L[J] := nil;
    end;
  end;
end;

function TMessageCenter.FindSenderList(Sender: TObject;
  var Index: Integer): TList;
  function ComparePointers(P1, P2: Pointer): Integer;
  begin
    if LongWord(P1) < LongWord(P2) then
      Result := -1
    else if LongWord(P1) > LongWord(P2) then
      Result := 1
    else
      Result := 0;
  end;
var
  L, H, I, C: Integer;
begin
  Result := nil;
  L := 0;
  H := FSenders.Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := ComparePointers(TList(FSenders[I])[0], Sender);
    if C < 0 then
      L := I + 1
    else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := FSenders[I];
        L := I;
      end;
    end;
  end;
  Index := L;
end;

initialization
finalization
  ShuttingDown := True;
  FreeAndNil(GMessageCenter);

end.


Component Download: http://www.eggcentric.com/download/MCDemo.zip

Delphi 6 - Imported Automation Events Bug

Problem/Question/Abstract:

Why don't any of the events in my imported ActiveX control work?

Answer:

Sad but true. Delphi 6's type library importer is badly broken with regards to the event sinks.

What's happening is that in InvokeEvent mehod that determines where to send the events by DispID each event handler called has its parameters reversed.

So for example in Delphi 5 where it's correct the imported event looks like this;

if Assigned(FOnRecognition) then
  FOnRecognition(Self, Params[0] {Integer}, Params[1] {OleVariant}, Params[2]
    {SpeechRecognitionType}, Params[3] {const ISpeechRecoResult});

while in Delphi 6 it looks like this;

if Assigned(FOnRecognition) then
  FOnRecognition(Self, Params[3] {const ISpeechRecoResult}, Params[2]
    {SpeechRecognitionType}, Params[1] {OleVariant}, Params[0] {Integer});

which just will not do.

The solution is to either

fix them all by hand
use an import created by Delphi 5
use official Borland pach for Delphi 6

Making adjustments to Delphi Colors

Problem/Question/Abstract:

How to make Delphi standard colors lighter or darker

Answer:

Here are some functions I use to make adjustments to the standard colors in Delphi.

The functions Darker and Lighter require 2 parameters and are used like this:

Panel1.Color := Darker(clBlue, 20);

This produces a panel color that is 20% darker than blue.

How it works:
Each of the three primary colors (Red,Green,Blue) can have values from 0 to 255 and can combine to form 16,777,216 possible colors. You can visualize the three primaries as the three axis' of a cube where the directions x, y and z correspond to the colors red, green and blue. Then each 3 dimensional point in the cube would represent one of the 16M colors. At the point in the cube where all the values are 0 (0,0,0) the color is black, and at (255,255,255) the color is white, (255,0,0) is pure red, etc.

If you visualize a line drawn between any color (r,g,b) and white (255,255,255)  then all the points that make up that line corespond to all valures of the color (r,g,b) as it becomes lighter and lighter until it reaches pure white.

That same for a line line drawn between any color (r,g,b) and black (0,0,0). The line represents all shades of that color as it darkens to pure black.

The function "Darker" returns a new color value that is the specified percentage closer to black. 100% is pure black.
The function "Lighter" returns a new color value that is the specified percentage closer to white. 100% is pure white.

function Darker(Color: TColor; Percent: Byte): TColor;
var
  r, g, b: Byte;
begin
  Color := ColorToRGB(Color);
  r := GetRValue(Color);
  g := GetGValue(Color);
  b := GetBValue(Color);
  r := r - muldiv(r, Percent, 100); //Percent% closer to black
  g := g - muldiv(g, Percent, 100);
  b := b - muldiv(b, Percent, 100);
  result := RGB(r, g, b);
end;

function Lighter(Color: TColor; Percent: Byte): TColor;
var
  r, g, b: Byte;
begin
  Color := ColorToRGB(Color);
  r := GetRValue(Color);
  g := GetGValue(Color);
  b := GetBValue(Color);
  r := r + muldiv(255 - r, Percent, 100); //Percent% closer to white
  g := g + muldiv(255 - g, Percent, 100);
  b := b + muldiv(255 - b, Percent, 100);
  result := RGB(r, g, b);
end;

I have also added these convenience functions that can be used like this:

Panel1.Color := Light(clBlue);
Panel1.Color := SlightlyDark(clRed);
Panel1.Color := VeryLight(clMagenta);
{etc. }

function SlightlyDark(Color: TColor): TColor;
begin
  Result := Darker(Color, 25);
end;

function Dark(Color: TColor): TColor;
begin
  Result := Darker(Color, 50);
end;

function VeryDark(Color: TColor): TColor;
begin
  Result := Darker(Color, 75);
end;

function SlightlyLight(Color: TColor): TColor;
begin
  Result := Lighter(Color, 25);
end;

function Light(Color: TColor): TColor;
begin
  Result := Lighter(Color, 50);
end;

function VeryLight(Color: TColor): TColor;
begin
  Result := Lighter(Color, 75);
end;