How to port the output of EnumWindows to a TStringList

Problem/Question/Abstract:

How to port the output of EnumWindows to a TStringList

Answer:

Untested:

procedure TForm1.Button1Click(Sender: TObject);
begin
  StrList.clear;
  EnumWindows(@EnumWindowsProc, integer(StrList));
end;

function EnumWindowsProc(Wnd: HWND; lst: TStringList): BOOL; stdcall;
var
  capttxt: array[0..128] of Char;
begin
  Result := True;
  if IsWindowVisible(Wnd) { skip invisible windows } and
  ((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) { only top-level windows}
    or (HWND(GetWindowLong(Wnd, GWL_HWNDPARENT)) = GetDesktopWindow))
    and ((GetWindowLong(Wnd, GWL_EXSTYLE) and
    WS_EX_TOOLWINDOW) = 0) {skip Tool windows } then
  begin
    SendMessage(Wnd, WM_GETTEXT, Sizeof(capttxt), integer(@capttxt));
    List.Items.Add(capttxt);
  end;
end;

Loading an exe in a memo field

Problem/Question/Abstract:

How can I read a binary file?
How can I show a binary file in a memo field?

Answer:

Solve 1:

Why?

This article has been written in answer to an old request by ismael u, asking how an executable can be loaded in a memo or rich memo field.

First a remark, executables should usually not be stored in a tmemo field, but rather in some blob field. However, there are some occasions on which one would like to view an executable. Studying (differences between) compiled  executables comes to mind.

I assume that Ismael means executable when he says exec, and the solution is rather simple.

How?

Loading a an executable in a memo field basically comes down to 2 steps. The first step is reading the file from disk and loading the file into memory, the second step is showing the loaded contents in the tmemo field.

The first step, reading the file from disk and loading it into memory, is rather easy. Perhaps TFileStream could be used, but I prefer the rather low level FileOpen function because of its performance. Also, when working with binary files, we must keep in mind that these files may contain #0 and many pointer based operations regard this as an end/of/string character.

Basically, here is the code, mostly a copy of the delphi5 help after fixing some minor bugs. Just create a form, add a button and a fileopendialog,
      
procedure TForm1.Button1Click(Sender: TObject);
var
  iFileHandle: Integer;
  iFileLength: Integer;
  iBytesRead: Integer;
  Buffer: PChar;
begin
  opendialog1.filter := 'executables|*.exe';
  if opendialog1.Execute then
  begin
    try
      iFileHandle := FileOpen(OpenDialog1.FileName, fmOpenRead or fmShareDenyNone);
      if iFileHandle > 0 then
      begin
        iFileLength := FileSeek(iFileHandle, 0, 2);
        FileSeek(iFileHandle, 0, 0);
        Buffer := PChar(AllocMem(iFileLength + 2));
        iBytesRead := FileRead(iFileHandle, Buffer^, iFileLength);
          // note that ^ is missing in D5 help.
        FileClose(iFileHandle);
      end;
    finally
      FreeMem(Buffer);
    end;
  end;
end;
    
The second step again poses us some questions. As the contents of the binary file will contain #0, how will we show them?

The first way is to convert the entire Buffer read above into a string and add this string to the memo. Doing this causes no technical problem, but the memo shows just a few characters. That's probably now what we want. The cause are the aforementioned #0 characters.

The second way is to go through the Buffer bit by bit, and switch to a new line whenever we encounter a #0. Doing so is easy, and reveals that an ordinary executable contains lots of #0 characters.

The third and probably best way is to show all characters in a hexagonal notation.
  
procedure TForm1.Button1Click(Sender: TObject);
var
  iFileHandle: Integer;
  iFileLength: Integer;
  iBytesRead: Integer;
  Buffer: PChar;
  i, linelength: integer;
  s: string;
  line: string;
  c: char;
  ordval, ordval1, ordval2: integer;
begin
  opendialog1.filter := 'executables|*.exe';
  if opendialog1.Execute then
  begin
    try
      iFileHandle := FileOpen(OpenDialog1.FileName, fmOpenRead or fmShareDenyNone);
      if iFileHandle > 0 then
      begin
        iFileLength := FileSeek(iFileHandle, 0, 2);
        FileSeek(iFileHandle, 0, 0);
        Buffer := PChar(AllocMem(iFileLength + 2));
        iBytesRead := FileRead(iFileHandle, Buffer^, iFileLength);
        // note that ^ is missing in D5 help.
        // 3 ways of conversion and show:
        // way 1: exe will contain \0 so this code shows only part of exe
        memo1.lines.add('way 1*********************************************');
        s := string(Buffer);
        memo1.lines.add(s);
        // way 2: use \0 as newline for purpose of displaying in memo1.
        memo1.lines.add('way 2*********************************************');
        LineLength := 0;
        Line := '';
        for i := 0 to iFileLength - 1 do
        begin
          if Buffer[i] = #0 then
          begin
            memo1.lines.add(Line);
            LineLength := 0;
            Line := '';
          end
          else
          begin
            inc(LineLength);
              // perhaps provision should be added for LineLength > max
                                                        delphi stringlength
            Line := Line + Buffer[i]; // memo1 will handle normal new line chars
          end;
        end;
        // way 3: display every char as ord
        memo1.lines.add('way 3*********************************************');
        Line := '';
        for i := 0 to iFileLength - 1 do
        begin
          c := Buffer[i];
          ordval := ord(c);
          ordval1 := ordval div 16;
          ordval2 := ordval mod 16;
          Line := Line + '0123456789ABCDEF'[ordval1 + 1] + '0123456789ABCDEF'[ordval2             + 1];
          if Length(Line) = 80 then
          begin
            memo1.lines.add(line);
            line := '';
          end;
        end;
        FileClose(iFileHandle);
      end;
    finally
      FreeMem(Buffer);
    end;
  end;
end;


Solve 2:

There is an inbuild delphi function (which I think appears in pre delphi 5)

BinToHex(Buffer, Text: PChar; BufSize: Integer);

which would create an output buffer in hex format.

Keep a dataset in dsInsert/dsEdit mode after validation fails

Problem/Question/Abstract:

Keep a dataset in dsInsert/dsEdit mode after validation fails

Answer:

If you want to keep a dataset in dsInsert/dsEdit mode after a validation fails, but do not want to loose your input, use Abort in the BeforePost() event.

(If you would use Dataset.Cancel, you'd loose the input and return to browse mode.)

procedure TForm1.Table1BeforePost(DataSet: TDataSet);
begin
  if Table1ID.Value <= 0 then
  begin
    // the data is invalid!!
    Showmessage('Error! Invalid value!');
    Abort
  end
  else
    Table1.Post;
end;

Create a flat TDBGrid

Problem/Question/Abstract:

How to create a flat TDBGrid

Answer:

This is an approach for creating a flat TDBGrid. It has some problems with its scrollbar tuning, but you can take it at least as an example.

{ ... }
type
  TMyGBGrid = class(TDBGrid)
  protected
    FFlat: boolean;
    procedure CreateWnd; override;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
      override;
    procedure InitScrollBars;
    procedure SetFlat(AValue: boolean);
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Flat: boolean read FFlat write SetFlat;
  end;

  { .... }

constructor TMyGBGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFlat := true;
end;

procedure TMyGBGrid.CreateWnd;
begin
  inherited CreateWnd;
  InitScrollBars;
end;

procedure TMyGBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState:
  TGridDrawState);

  procedure xXDrawBorder(var ABorderRect: TRect);
  begin
    InflateRect(ABorderRect, 1, 1);
    Frame3D(Canvas, ABorderRect, clBtnShadow, clBtnShadow, 1);
    Frame3D(Canvas, ABorderRect, clBtnHighlight, clBtnFace, 1);
  end;

begin
  inherited DrawCell(ACol, ARow, ARect, AState);
  if Flat and ((ACol = 0) or (ARow = 0)) then
  begin
    if (ARow = 0) and (dgTitles in Options) then
      xXDrawBorder(ARect)
    else if (ACol = 0) and (dgIndicator in Options) then
      xXDrawBorder(ARect);
  end
end;

procedure TMyGBGrid.InitScrollBars;
var
  XVerScrollInfo, XHorScrollInfo: TScrollInfo;
begin
  if FFlat then
  begin
    GetScrollInfo(Handle, SB_VERT, XVerScrollInfo);
    GetScrollInfo(Handle, SB_HORZ, XHorScrollInfo);
    InitializeFlatSB(Handle);
    FlatSB_SetScrollInfo(Handle, SB_VERT, XVerScrollInfo, true);
    FlatSB_SetScrollInfo(Handle, SB_HORZ, XHorScrollInfo, true);
    FlatSB_SetScrollProp(Handle, WSB_PROP_VSTYLE, FSB_ENCARTA_MODE, true);
    FlatSB_SetScrollProp(Handle, WSB_PROP_HSTYLE, FSB_ENCARTA_MODE, true);
    FlatSB_SetScrollProp(Handle, WSB_PROP_VBKGCOLOR, clGreen, true);
    FlatSB_SetScrollProp(Handle, WSB_PROP_HBKGCOLOR, clBlue, true);
  end;
end;

procedure TMyGBGrid.SetFlat(AValue: boolean);
begin
  if AValue <> FFlat then
  begin
    FFlat := AValue;
    RecreateWnd;
  end;
end;

How to delete multiple files from a directory

Problem/Question/Abstract:

How to delete multiple files from a directory

Answer:

procedure DeleteFiles(sMask, sPath: string);
var
  SearchRec: TSearchRec;
  Found: Integer;
begin
  sPath := IncludeTrailingPathDelimiter(sPath);
  Found := SysUtils.FindFirst(sPath + sMask, faAnyFile, SearchRec);
  try
    while (Found = 0) do
    begin
      if not (SearchRec.Attr and faDirectory > 0) then
        SysUtils.DeleteFile(sPath + SearchRec.Name);
      Found := SysUtils.FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

Usage:

DeleteFiles('*.txt', 'c:\myfiles');

Easiest Way Drawing Transparent Image

Problem/Question/Abstract:

How to draw an image transparently ?

Answer:

Here is anohter way to draw a transparent image. Only using Delphi properties and method (Image).

Here is the example code:

// make draw proc to draw transparently

procedure MyTransparentDraw(src, dest: TBitmap; x, y: integer; warna: TColor);
begin
  src.Transparent := true;
  src.TransparentMode := tmFixed;
  src.TransparentColor := warna;
  dest.Canvas.Draw(x, y, src);
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  TRANS_COLOR = clYellow; // change with transparent color you want
var
  bmp, bmp2: TBitmap;
begin
  if (OpenPictureDialog1.Execute) then
  begin
    Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
    bmp := TBitmap.Create;
    try
      bmp.Width := Image1.Width;
      bmp.Height := Image1.Height;
      bmp.Assign(Image1.Picture.Bitmap);
      bmp2 := TBitmap.Create;
      try
        bmp2.Width := bmp.Width;
        bmp2.Height := bmp.Height;
        MyTransparentDraw(bmp, bmp2, 0, 0, TRANS_COLOR);
        Image1.Canvas.Draw(0, 0, bmp2);
      finally
        bmp2.Free;
      end;
    finally
      bmp.Free;
    end;
  end;
end;

To try above code, just copy and paste those code, then click on button to choose an image to be drawn transparently. You can change the value of "TRANS_COLOR" above with any other color that you want to be the transparent color of you image.

Conserving Windows resources when using TPageControl

Problem/Question/Abstract:

Complex forms can use up a lot of the Windows resources. This article describes a method for reducing the drain on the Windows resources.

Answer:

In my application there is a form with lots of components on it; 1047 components to be exact.  In my development environment, WindowsNT, this did not cause any problems but under Windows 98, my application would crash if a user tried to create a second instance of this form.  The problem was that in Windows 98, there are a limited number of Windows resources and one instance of my form used 42% of the Windows resources.  With the operating system already using 20% of the resources, there weren't enough resources left to create a second instance of the form.

In researching this problem I came across a thread in alt.comp.lang.borland-delphi by Ken Phipps, Bruce Roberts, and M.H. Avegaart that gave most of a solution to the problem.  The thread extended from Jan. 13, 2001 to Jan. 16, 2001.  There is also an article on the Borland web site that gives some related information (TI1375D.txt; http://community.borland.com/article/0,1410,16375,00.html).

The following is the solution I implemented in my program.  It solved my problem.

First, I created the ConserveResourcesUnit shown below.  I called FreeFormResources in the OnCreate event handler of each form that had a TPageControl.  I called FreePageControlResources in the OnChange event handler of each TPageControl.  I could have gone further and made a component that did the same thing after the page control was created and when the ActivePage was changed but it didn't seem worth the effort.  I could also have called FreePageControlResources when the ActivePage of a TPageControl was changed programatically but I haven't gotten around to that yet.  Another option would have been to redesign the form to use fewer TWinControls but that would have been a lot of effort and would have created other problems.

There is one tricky bit.  If you have a TPageControl on a tab of another TPageControl and you want to set the TabVisible property of one of the tabs on the former TPageControl you may need to call HandleNeeded for all the tabs on the former TPageControl before setting the TabVisible property.  You can call FreePageControlResources afterwards to free-up resources.  If you don't do this, an error can occur in the VCL when you try to set the TabVisible property.

If you use a TTabbedNotebook rather than a TPageControl, see the article on the Borland web site cited above.

unit ConserveResourcesUnit;

interface

uses Windows, Classes, Controls, Forms, comctrls;

procedure FreePageControlResources(const APageControl: TPageControl;
  const FormHandle: HWND);

procedure FreeFormResources(const AForm: TForm);

implementation

type
  TMyWinControl = class(TWinControl);

procedure FreePageControlResources(const APageControl: TPageControl;
  const FormHandle: HWND);
var
  Index: integer;
begin
  //  LockWindowUpdate prevents any drawing in a given window}
  LockWindowUpdate(FormHandle);
  with APageControl do
  begin
    for Index := 0 to PageCount - 1 do
    begin
      // DestroyHandle is protected so a typecast is required
      // to expose it.
      // Usually, the handles will be automatically recreated when needed.
      // However, in setting the TabVisible property, they may not be recreated
      // without a direct call to HandleNeeded.
      if Pages[Index] <> ActivePage then
        TMyWinControl(Pages[Index]).DestroyHandle;
    end;
  end;
  {Release the Lock on the Form so any Form drawing can work}
  LockWindowUpdate(0);
end;

procedure FreeFormResources(const AForm: TForm);
var
  AComponent: TComponent;
  Index: integer;
begin
  for Index := 0 to AForm.ComponentCount - 1 do
  begin
    AComponent := AForm.Components[Index];
    if AComponent is TPageControl then
    begin
      FreePageControlResources(TPageControl(AComponent), AForm.Handle);
    end;
  end;
end;

end.

How to save and restore font selections to a text file

Problem/Question/Abstract:

I need to save and restore Font selections to a text file. I was able to convert all the font attributes except for style to and from strings using one line expressions.

Answer:

Solve 1:

Here's one way of doing it:

function StyleToStr(Style: TFontStyles): string;
begin
  SetLength(Result, 4);
  {T = true, S = false 83 is ordinal value of S, if true then S + 1 (84) = T}
  Result[1] := Char(Integer(fsBold in Style) + 83);
  Result[2] := Char(Integer(fsItalic in Style) + 83);
  Result[3] := Char(Integer(fsUnderline in Style) + 83);
  Result[4] := Char(Integer(fsStrikeOut in Style) + 83);
  {replace all S to F's if you like}
  Result := StringReplace(Result, 'S', 'F', [rfReplaceAll]);
end;

function StrToStyle(Str: string): TFontStyles;
begin
  Result := [];
  {T = true, S = false}
  if Str[1] = 'T' then
    Include(Result, fsBold);
  if Str[2] = 'T' then
    Include(Result, fsItalic);
  if Str[3] = 'T' then
    Include(Result, fsUnderLine);
  if Str[4] = 'T' then
    Include(Result, fsStrikeOut);
end;


Solve 2:

I'd suggest this:

function StyleToStr(Style: TFontStyles): string;
const
  Chars: array[Boolean] of Char = ('F', 'T');
begin
  SetLength(Result, 4);
  Result[1] := Chars[fsBold in Style];
  Result[2] := Chars[fsItalic in Style];
  Result[3] := Chars[fsUnderline in Style];
  Result[4] := Chars[fsStrikeOut in Style];
end;


Solve 3:

A more algorithmic approach:

function FontStylesToStr(Style: TFontStyles): string;
var
  I: TFontStyle;
begin
  SetLength(Result, High(TFontStyle) + 1);
  for I := Low(TFontStyle) to High(TFontStyle) do
    if I in Style then
      Result[Ord(I) + 1] := 'F'
    else
      Result[Ord(I) + 1] := 'T';
end;

function StrToFontStyles(Str: string): TFontStyles;
var
  I: TFontStyle;
begin
  Result := [];
  for I := Low(TFontStyle) to High(TFontStyle) do
    if Str[Ord(I) + 1] = 'T' then
      Include(Result, I);
end;


Solve 4:

May I propose that you save the font style using a numeric representation of the bit pattern. One special consideration during the conversion would be the size of the enumeration. That is, make sure you use an integer type that has the same boundary as the set type. For example, there are four possible font styles in TFontStyles, it would be stored as a byte.

function FontStylesToInt(Styles: TFontStyles): Integer;
begin
  Result := byte(Styles)
end;

function IntToFontStyles(Value: integer): TFontStyles;
begin
  Result := TFontStyles(byte(Value))
end;

If you are a purist, replace 'integer's with 'byte's

How to use ScanLine

Problem/Question/Abstract:

Can someone explain to me how to use the ScanLine function? I tried the example in the Help, only got a black box.

Answer:

type
  PRGBs = ^TRGBs;
  TRGBs = array[0..1000000] of TRGBTriple;

var
  r, g, b: Byte2DArray; {customer implemented}

procedure VirtualImageRGB.fromimage(t: TImage);
var
  x, y: Integer;
  P: PRGBs;
begin
  for y := 0 to t.picture.Bitmap.Height - 1 do
  begin
    P := PRGBs(t.picture.Bitmap.Scanline[y]);
    for x := 0 to t.picture.Bitmap.Width - 1 do
      with P^[x] do
      begin
        r[x, y] := rgbtRed;
        g[x, y] := rgbtGreen;
        b[x, y] := rgbtBlue;
      end;
  end;
end;

procedure VirtualImageRGB.toimage(t: TImage);
var
  x, y: Integer;
  P: PRGBs;
begin
  for y := 0 to t.picture.Bitmap.Height - 1 do
  begin
    P := PRGBs(t.picture.Bitmap.Scanline[y]);
    for x := 0 to t.picture.Bitmap.Width - 1 do
      with P^[x] do
      begin
        rgbtRed := r[x, y];
        rgbtGreen := g[x, y];
        rgbtBlue := b[x, y];
      end;
  end;
  t.canvas.draw(0, 0, t.picture.Bitmap);
end;

Display different splash screens anytime during program execution

Problem/Question/Abstract:

How to display different splash screens anytime during program execution

Answer:

Solve 1:

I wanted to be able to display a splash screen anytime during the program run with different durations and different images each time. The problem with using the Release method from within a form is that it doesn't set the variable referencing the splash form to NIL. When the splash form is released, I need to reset the reference so that I can test it when displaying the form to make sure it's NIL (that there isn't one already up). I could easily have made the reference public and set it to NIL after calling Release from within the timer event, but that's not very reusable.

What I ended up doing is creating a class (TFormWithSplash) derived from TForm that has all mechanisms necessary to handle the splash screen itself. Then, any form I want to be able to display splashscreens, I simply derive from this class instead of TForm. The unit that defines TFormWithSplash has a simple form within it that contains an image and timer control. The ShowSplash method of TFormWithSplash creates an instance of this form and displays it. This form then loads the image file and starts the timer. When the timer elapses, the form closes itself and sends a user defined message its parent form which frees the reference and resets it to nil. Everything but the PicFileName, SplashDuration, StayOnTop properties and the ShowSplash function calls are invisible to the programmer. Here is the code; it still needs a few features, but seems to work well.

unit SplashFrm;

interface

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

const
  WM_SPLASHCLOSED = WM_USER + 113;

type
  TFormWithSplash = class;
  TSplashForm = class(TForm)
    Image1: TImage;
    Timer1: TTimer;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Timer1Timer(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
  private
    CloseOnDeactivate: Boolean;
    procedure LoadAndDisplay(PicFile: string);
  public
    constructor Create(Owner: TFormWithSplash; DisplayFor: Cardinal;
      CloseOnLostFocus: Boolean; TopMost: Boolean);
  end;

  TFormWithSplash = class(TForm)
    PicFile: string;
    SplashForm: TSplashForm;
    procedure SetPicFile(FileName: string);
    procedure OnSplashClosed(var msg: TMessage); message WM_SPLASHCLOSED;
  public
    SplashDuration: Cardinal;
    StayOnTop, CloseOnLostFocus: Boolean;
    constructor Create(Owner: TComponent); override;
    procedure ShowSplash;
    property SplashPicFile: string read PicFile write SetPicFile;
  end;

implementation

{$R *.DFM}

constructor TFormWithSplash.Create(Owner: TComponent);
begin
  SplashForm := nil;
  PicFile := '';
  StayOnTop := True;
  CloseOnLostFocus := False;
  inherited Create(Owner);
end;

procedure TFormWithSplash.OnSplashClosed(var msg: TMessage);
begin
  SplashForm.Free;
  SplashForm := nil;
end;

procedure TFormWithSplash.SetPicFile(FileName: string);
begin
  if not FileExists(FileName) then
    raise EInOutError.Create('Couldn''t load image file: ' + FileName)
  else
    PicFile := FileName;
end;

procedure TFormWithSplash.ShowSplash;
begin
  if PicFile = '' then
    Exit;
  while Assigned(SplashForm) do
    Application.ProcessMessages;
  SplashForm := TSplashForm.Create(self, SplashDuration, CloseOnLostFocus, StayOnTop);
  SplashForm.LoadAndDisplay(PicFile);
end;

constructor TSplashForm.Create(Owner: TFormWithSplash; DisplayFor: Cardinal;
  CloseOnLostFocus: Boolean; TopMost: Boolean);
begin
  inherited Create(Owner);
  CloseOnDeactivate := CloseOnLostFocus;
  if TopMost then
    FormStyle := fsStayOnTop;
  Image1.AutoSize := True;
  Timer1.Interval := DisplayFor * 1000;
end;

procedure TSplashForm.LoadAndDisplay(PicFile: string);
begin
  Image1.Picture.LoadFromFile(PicFile);
  ClientHeight := Image1.Picture.Height + 1;
  ClientWidth := Image1.Picture.Width + 1;
  Left := Screen.Width div 2 - Width div 2;
  Top := Screen.Height div 2 - Height div 2;
  Show;
end;

procedure TSplashForm.FormShow(Sender: TObject);
begin
  Application.RestoreTopmosts;
  Timer1.Enabled := True;
end;

procedure TSplashForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  PostMessage(TFormWithSplash(Owner).Handle, WM_SPLASHCLOSED, 0, 0);
end;

procedure TSplashForm.Timer1Timer(Sender: TObject);
begin
  Close;
end;

procedure TSplashForm.FormDeactivate(Sender: TObject);
begin
  if CloseOnDeactivate then
  begin
    Timer1.Enabled := False;
    Close;
  end;
end;

end.


Solve 2:

This information is found in the View Menu and then view Project Source.

begin
  SplashScreen := TSplashScreen.Create(Application); //These 3 lines
  SplashScreen.Show; //Added Manually
  SplashScreen.Update; //to load SplashScreen
  Application.Initialize;
  Application.Title := 'Application Title';
  Application.CreateForm(TForm1, Form1);
  SplashScreen.Hide; //These 2 added
  SplashScreen.Free; //manually to close Splash
  Application.Run;
end.

In Project Options, set SplashScreen Form to be an available form, not Autocreate.

Building an Easy-to-Use Parser/Parsing Framework (Part I)

Problem/Question/Abstract:

How to create a simple parsing framework to parse any kind of data?

Answer:

Note:

The full sourcecodes for all components & examples descripted in the following article are available as an open-source project under SourceForge:

  Parser Framework

A second article was released on 29.01.2002 with a more detailed example:

Building an Easy-to-Use Parser/Parsing Framework (Part II)

Today, we wonna speak about "how to create a simple parser framework" in Delphi. Our goal will be a class solutions which helps up to parse any kind of data and store all relevant informations in an easy-to- access object model.

At the end of this article, we've developed a small utility, which generates a simple object model of a .dtd file and output it's xml pendant from a given starting node. In other words, we're using the parsing framework to create a parser, which is able to parse a .dtd file, extract all neccessary tags, store them in the object model and generates the xml output. Note: This utility uses a simply dtd- parser model, which don't include all routines to parse all kinds of dtd datas - it's up to you to include those features.

Our claims to the framework and object model are:

easy to use.
save/loadable object trees.
integrated error reporting.
expandable.

Okay, now let's start to develope the main parsing engine. Delphi comes with a unit called CopyPrsr which includes  the simple stream parser object TCopyParser. Try to take a look into that file to understand how it works - it's located under $(DELPHI)\Source\Internet\CopyPrsr.pas. Our framework parser is derived from that idea, but uses a simple string instead of the stream and includes some additional functions:

The boiler plate:

unit StringParser;

interface

uses
  Classes;

const
  { Additional Parser special tokens }

  toEOL = char(6);
  toBOF = char(7);

type
  { TSysCharSet }

  TSysCharSet = set of Char;

  { TStringParser }

  TStringParser = class
  private
    { Private declarations }
    FParseString: string;
    FLineTokens: Integer;
    FSourceLine: Integer;
    FSourcePos: Integer;
    FTokenPos: Integer;
    FToken: Char;
    procedure SkipBlanks;
    function GetParseString: string;
    function GetSourcePos: Integer;
    function GetTokenString: string;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create;
    function LoadFromFile(const FileName: string): Boolean;
    function LoadFromStream(const Stream: TStream): Boolean;
    function SkipToEOF: string;
    function SkipToEOL: string;
    function SkipToken: Char;
    function SkipTokenString: string;
    function SkipToToken(const AToken: Char): string; overload;
    function SkipToToken(const AToken: TSysCharSet): string; overload;
    function SkipToTokenString(const ATokenString: string): string;
    property ParseString: string read GetParseString;
    property SourceLine: Integer read FSourceLine;
    property SourcePos: Integer read GetSourcePos;
    property Token: Char read FToken;
    property TokenString: string read GetTokenString;
  end;

As you can see, there are many public helper functions which you can use to parse the data. The main functions are LoadFromFile and LoadFromStream, which needs the name of the file to be parsed as the only parameter. Both functions loads the content of the file and store it to the string FParseString which can be accessed through the denominator property:

LoadFromFile/LoadFromStream:

function TStringParser.LoadFromFile(const FileName: string): Boolean;
var
  Stream: TMemoryStream;
begin
  Result := False;
  if not FileExists(FileName) then
    Exit;
  Stream := TMemoryStream.Create;
  try
    Stream.LoadFromFile(FileName);
    Result := LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

function TStringParser.LoadFromStream(const Stream: TStream): Boolean;
var
  MemStream: TMemoryStream;
begin
  Result := False;
  if not (assigned(Stream)) then
    Exit;
  MemStream := TMemoryStream.Create;
  try
    Stream.Seek(0, soFromBeginning);
    MemStream.CopyFrom(Stream, Stream.Size);
    FParseString := StrPas(MemStream.Memory);
    SetLength(FParseString, MemStream.Size);
    FParseString := Concat(FParseString, toEOF);
    FToken := toBOF;
    Result := True;
  finally
    MemStream.Free;
  end;
end;

The main functionality of the parsing engine is the extraction of so- called tokens. A token can be a seperator (like CR, LF or EOF) or a symbol, which can be a keyword if you plan to parse a programing language. The following functions are used to skip blank characters (which are used to seperate symbols and aren't relevant) and to extract/skip the next token symbol:

Token related functions (pullout only):

procedure TStringParser.SkipBlanks;
begin
  while True do
  begin
    FToken := FParseString[FTokenPos];
    case FToken of
      #10:
        begin
          Inc(FSourceLine);
          FLineTokens := FTokenPos;
        end;
      toEOF, #33..#255:
        Exit;
    end;
    Inc(FTokenPos);
  end;
end;

function TStringParser.SkipToken: Char;
const
  KeySet = ['A'..'Z', 'a'..'z', '0'..'9', '_'];
begin
  SkipBlanks;
  FSourcePos := FTokenPos;
  if FParseString[FTokenPos] = toEOF then
    FToken := toEOF
  else if FParseString[FTokenPos] in KeySet then
  begin
    while FParseString[FTokenPos] in KeySet do
      Inc(FTokenPos);
    FToken := toSymbol;
  end
  else
  begin
    FToken := FParseString[FTokenPos];
    Inc(FTokenPos);
  end;
  Result := FToken;
end;

function TStringParser.SkipToToken(const AToken: TSysCharSet): string;
begin
  FSourcePos := FTokenPos;
  while not ((FParseString[FTokenPos] = toEOF) or (FParseString[FTokenPos] in AToken))
    do
  begin
    if FParseString[FTokenPos] = #10 then
    begin
      Inc(FSourceLine);
      FLineTokens := FTokenPos;
    end;
    Inc(FTokenPos);
  end;
  if FParseString[FTokenPos] = toEOF then
    FToken := toEOF
  else
    FToken := FParseString[FTokenPos];
  Result := GetTokenString;
  if FToken <> toEOF then
    SkipToken;
end;

The absent functions includes alternativ possibilities to extract or skip the tokens, like SkipToTokenString or SkipToEof. Well, the next step is to create the object model, which holds all our parsed informations. As I mentioned earlier, the goal of this article it to create a simple dtd parser, so we'll create an object model to store dtd
informations.

A dtd file is used to descripe the syntax rules of a xml file, like:

DTD example:

key CDATA #REQUIRED
value CDATA #REQUIRED
>

This example demonstrated the simplest way of a dtd structure. It's not the purpose of this article to develope a highly flexible dtd parser which spots all dtd grammas, so we only include the weightly ones. Root of each object model is the document, which holds all other objects as collections:

The Root Document:

{ TDTDDocument }

TDTDDocument = class(TPersistent)
private
  { Private declarations }
  FEntities: TDTDEntities;
  FElements: TDTDElements;
  procedure SetEntities(Value: TDTDEntities);
  procedure SetElements(Value: TDTDElements);
public
  { Public declarations }
  constructor Create;
  destructor Destroy; override;
  procedure Assign(Source: TPersistent); override;
published
  { Published declarations }
  property Entities: TDTDEntities read FEntities write SetEntities;
  property Elements: TDTDElements read FElements write SetElements;
end;

As you can see, our document gives us the access of some other types of data: Entities and Elements. Entities are very hard to parse, so it's a good lesson for you to include that feature. Parsing elements is quite easier, so this type of data is better to explain here. Look at the dtd example some rows above this. You can see, that a dtd element is descripted as followed:

Our object model needs some extra fields to store such element informations. If you are not familiar with dtd or xml, look at W3CSchools - it's a good starting point to learn more about that topic. So, take a look at the following  object structure:

TDTDDocument
  |
  o--TDTDEntities
  |
  o--TDTElements
    |
    o--TDTDElementTyp
    |
    o--TDTDAttributes
      |
      o--TDTDAttributeTyp
      o--TDTDAttributeStatus
      o--Default: string
      o--TDTDEnums
    o--TDTDChild
      |
      o--TDTDTyp
      o--TDTDChilds

I've tried to "pack" the dtd grammars into an easy object model as you can see above:

Each document contains a collection of elements. Each element is descripted by an elementtype and containes in turn a collection of attributes and childs. Each attribute again is descripted by an attributetype and contains a collection of enum(erations) and so forth. Followed a code cantle from the element implementation, it's not suggestive to show you the whole code here - it's quit long and a little bit more complex:

TDTDElement:

unit DTD_Document;

interface

uses
  Classes;

type

  ...

  { TDTDElementTyp }

  TDTDElementTyp =
    (etAny, etEmpty, etData, etContainer);

  { TDTDElementStatus }

  TDTDElementStatus =
    (esRequired, esRequiredSeq, esOptional, esOptionalSeq);

  { TDTDItem }

  TDTDItem = class(TCollectionItem)
  private
    { Private declarations }
    FName: string;
  public
    { Public declarations }
    procedure Assign(Source: TPersistent); override;
  published
    { Published declarations }
    property Name: string read FName write FName;
  end;

  { TDTDItems }

  TDTDItems = class(TCollection)
  private
    { Private declarations }
    function GetItem(Index: Integer): TDTDItem;
    procedure SetItem(Index: Integer; Value: TDTDItem);
  public
    { Public declarations }
    function Add: TDTDItem;
    function Find(const Name: string): TDTDItem;
    property Items[Index: Integer]: TDTDItem read GetItem write SetItem; default;
  end;

  ...

  { TDTDElement }

  TDTDElement = class(TDTDProperty)
  private
    { Private declarations }
    FTyp: TDTDElementTyp;
    FAttributes: TDTDAttributes;
    FChilds: TDTDChilds;
    procedure SetAttributes(Value: TDTDAttributes);
    procedure SetChilds(Value: TDTDChilds);
  public
    { Public declarations }
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    { Published declarations }
    property Typ: TDTDElementTyp read FTyp write FTyp;
    property Attributes: TDTDAttributes read FAttributes write SetAttributes;
    property Childs: TDTDChilds read FChilds write SetChilds;
  end;

  { TDTDElements }

  TDTDElements = class(TDTDProperties)
  private
    { Private declarations }
    function GetItem(Index: Integer): TDTDElement;
    procedure SetItem(Index: Integer; Value: TDTDElement);
  public
    { Public declarations }
    function Add: TDTDElement;
    function Find(const Name: string): TDTDElement;
    property Items[Index: Integer]: TDTDElement read GetItem write SetItem; default;
  end;

  ...

implementation

...

{ TDTDItem }

procedure TDTDItem.Assign(Source: TPersistent);
begin
  if Source is TDTDItem then
  begin
    Name := TDTDItem(Source).Name;
    Exit;
  end;
  inherited Assign(Source);
end;

{ TDTDItems }

function TDTDItems.Add: TDTDItem;
begin
  Result := TDTDItem(inherited Add);
end;

function TDTDItems.Find(const Name: string): TDTDItem;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to Count - 1 do
    if CompareStr(Items[i].Name, Name) = 0 then
    begin
      Result := Items[i];
      Break;
    end;
end;

function TDTDItems.GetItem(Index: Integer): TDTDItem;
begin
  Result := TDTDItem(inherited GetItem(Index));
end;

procedure TDTDItems.SetItem(Index: Integer; Value: TDTDItem);
begin
  inherited SetItem(Index, Value);
end;

...

{ TDTDElement }

constructor TDTDElement.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FAttributes := TDTDAttributes.Create(TDTDAttribute);
  FChilds := TDTDChilds.Create(TDTDChild);
end;

destructor TDTDElement.Destroy;
begin
  FAttributes.Free;
  FChilds.Free;
  inherited Destroy;
end;

procedure TDTDElement.Assign(Source: TPersistent);
begin
  if Source is TDTDElement then
  begin
    Typ := TDTDElement(Source).Typ;
    Attributes.Assign(TDTDElement(Source).Attributes);
    Childs.Assign(TDTDElement(Source).Childs);
  end;
  inherited Assign(Source);
end;

procedure TDTDElement.SetAttributes(Value: TDTDAttributes);
begin
  FAttributes.Assign(Value);
end;

procedure TDTDElement.SetChilds(Value: TDTDChilds);
begin
  FChilds.Assign(Value);
end;

{ TDTDElements }

function TDTDElements.Add: TDTDElement;
begin
  Result := TDTDElement(inherited Add);
end;

function TDTDElements.Find(const Name: string): TDTDElement;
begin
  Result := TDTDElement(inherited Find(Name));
end;

function TDTDElements.GetItem(Index: Integer): TDTDElement;
begin
  Result := TDTDElement(inherited GetItem(Index));
end;

procedure TDTDElements.SetItem(Index: Integer; Value: TDTDElement);
begin
  inherited SetItem(Index, Value);
end;

The advantage of this object model is, that you're able to easily add the document to a standard component and use Delphi's internal streaming technology to load and save the object contents of a parsed file.

The next step will be the developing of the real dtd parser. Do you remember the TStringParser descripted at the top of this article? We'll using this class to build up our parser. But, we don't want to create a parser from scratch each time we're about to parse a new kind of data - it's not mind of a framework. So first, we'll develope a small parser class from which we will inherit our dtd parser. This parent class should include the error reporting and accessable fields to some other informations:

The Private Parser class:

unit PrivateParser;

interface

uses
  Classes, SysUtils, StringParser;

type
  { TParserError }

  TParserError = class(TCollectionItem)
  private
    { Private declarations }
    FFileName: string;
    FLine: Integer;
    FMessage: string;
    FPosition: Integer;
  public
    { Public declarations }
    procedure Assign(Source: TPersistent); override;
  published
    { Published declarations }
    property FileName: string read FFileName write FFileName;
    property Line: Integer read FLine write FLine;
    property Message: string read FMessage write FMessage;
    property Position: Integer read FPosition write FPosition;
  end;

  { TParserErrors }

  TParserErrors = class(TCollection)
  private
    { Private declarations }
    function GetItem(Index: Integer): TParserError;
    procedure SetItem(Index: Integer; Value: TParserError);
  public
    { Public declarations }
    function Add: TParserError;
    property Items[Index: Integer]: TParserError read GetItem write SetItem; default;
  end;

  { TValidationParser }

  TValidationParser = class
  private
    { Private declarations }
    FErrors: TParserErrors;
    procedure SetErrors(const Value: TParserErrors);
  public
    { Public declarations }
    constructor Create;
    destructor Destroy; override;
    procedure AddError(const AMessage: string; Parser: TStringParser; const AFileName:
      string = '');
    procedure AddErrorFmt(const AMessage: string; Params: array of const; Parser:
      TStringParser; const AFileName: string = '');
    property Errors: TParserErrors read FErrors write SetErrors;
  end;

implementation

{ TParserError }

procedure TParserError.Assign(Source: TPersistent);
begin
  if Source is TParserError then
  begin
    Line := TParserError(Source).Line;
    Message := TParserError(Source).Message;
    Position := TParserError(Source).Position;

    Exit;
  end;

  inherited Assign(Source);
end;

{ TParserErrors }

function TParserErrors.Add: TParserError;
begin
  Result := TParserError(inherited Add);
end;

function TParserErrors.GetItem(Index: Integer): TParserError;
begin
  Result := TParserError(inherited GetItem(Index));
end;

procedure TParserErrors.SetItem(Index: Integer; Value: TParserError);
begin
  inherited SetItem(Index, Value);
end;

{ TValidationParser }

constructor TValidationParser.Create;
begin
  inherited Create;
  FErrors := TParserErrors.Create(TParserError);
end;

destructor TValidationParser.Destroy;
begin
  FErrors.Free;
  inherited Destroy;
end;

procedure TValidationParser.SetErrors(const Value: TParserErrors);
begin
  FErrors.Assign(Value);
end;

procedure TValidationParser.AddErrorFmt(const AMessage: string; Params: array of
  const; Parser: TStringParser; const AFileName: string = '');
begin
  with FErrors.Add do
  begin
    FileName := AFileName;
    Line := Parser.SourceLine;
    Message := Format(AMessage, Params);
    Position := Parser.SourcePos;
  end;
end;

procedure TValidationParser.AddError(const AMessage: string; Parser: TStringParser;
  const AFileName: string = '');
begin
  AddErrorFmt(AMessage, [], Parser, AFileName);
end;

end.

Now we can start developing the real parser by inheriting it from the TValidationParser. Again, I don't want to show you the whole sourcecode here, so I pick up only the sapid one. Our dtd parser is a so- called two-way parser, i.e. it uses the first pass to parse the elements and the second pass to parse the attributes. This is useful, because an attibute can refer to an element which is placed below it and otherwise we'll get some unneeded errors. The main method of our parse is Parse, which  needs the name of the file to be parsed as the first parameter, and a pre-initialized TDTDDocument as the second parameter. A sample call should looks like:

Sample Call:

// Create DTDDocument.
DTDDocument := TDTDDocument.Create;
try
  // Create DTDParser.
  DTDParser := TDTDParser.Create;
  try
    // Parse File.
    DTDParser.Parse(FileName, DTDDocument);

    // Display possible Errors.
    if DTDParser.Errors.Count > 0 then
    begin
      for i := 0 to DTDParser.Errors.Count - 1 do
        with DTDParser.Errors[i] do
          WriteLn(Format('Error in Line %d, Pos %d: %s...', [Line, Position,
            Message]));
      Exit;
    end;

    ...

    // Free DTDParser.
  finally
    DTDParser.Free;
  end;

  // Free DTDDocument.
finally
  DTDDocument.Free;
end;

But now, let's take a look at some sourcecode lines of the parser implementation. The first think we had to do is to inherited our parser from the parent class:

Parser Implementation (Snippet):

type
  { EDTDParser }

  EDTDParser = class(Exception);

  { TDTDParser }

  TDTDParser = class(TValidationParser)
  private
    { Private declarations }
    procedure ParseElement(Parser: TStringParser; Document: TDTDDocument; const Pass:
      Integer);
    procedure ParseAttlist(Parser: TStringParser; Document: TDTDDocument);
    procedure ParseFile(const FileName: string; Document: TDTDDocument; const Pass:
      Integer = 0);
  public
    { Public declarations }
    procedure Parse(const FileName: string; var Document: TDTDDocument);
  end;

Afterwards we implement the Parse method which calls the internal method ParseFile on her part:

Method "Parse":

procedure TDTDParser.Parse(const FileName: string; var Document: TDTDDocument);
var
  TmpDocument: TDTDDocument;
begin
  if not assigned(Document) then
    raise EDTDParser.Create('Document not assigned!');
  TmpDocument := TDTDDocument.Create;
  try
    ParseFile(FileName, TmpDocument);
    if Errors.Count = 0 then
      Document.Assign(TmpDocument);
  finally
    TmpDocument.Free;
  end;
end;

As you can see, we create a special temporar document to store the parsed objects in. I've done this because I don't want to return the document if it is full of errors - I assign a exact copy of the objects only, if no errors occured. The method ParseFile implements the proper parsing calls to the StringParser and creates the real objects. Followed a code snippet of the method body:

Method "ParseFile":

procedure TDTDParser.ParseFile(const FileName: string;
  Document: TDTDDocument; const Pass: Integer = 0);
var
  Parser: TStringParser;
begin
  Parser := TStringParser.Create;
  try
    if not Parser.LoadFromFile(FileName) then
    begin
      AddErrorFmt('File "%s" not found', [FileName], Parser);
      Exit;
    end;
    while True do
    begin
      while not (Parser.Token in [toEOF, '<']) do
        Parser.SkipToken;
      if Parser.Token = toEOF then
        Break;
      Parser.SkipToken;
      if Parser.Token <> '!' then
      begin
        if not (Parser.Token in ['?']) and (Pass = 1) then
          AddError('InvalidToken', Parser);
        Continue;
      end;
      if Parser.SkipToken <> toSymbol then
      begin
        if (Parser.Token <> '-') and (Pass = 1) then
          AddError('InvalidToken', Parser);
        Continue;
      end;
      if UpperCase(Parser.TokenString) = 'ENTITY' then
        Continue;
      if UpperCase(Parser.TokenString) = 'ELEMENT' then
        ParseElement(Parser, Document, Pass)
      else if UpperCase(Parser.TokenString) = 'ATTLIST' then
      begin
        if Pass = 1 then
          ParseAttlist(Parser, Document);
      end
      else if Pass = 1 then
        AddErrorFmt('Invalid Symbol "%s"', [Parser.TokenString], Parser);
    end;
    if Pass = 0 then
      ParseFile(FileName, Document, 1);
  finally
    Parser.Free;
  end;
end;

This method calls some other functions (ParseElement and ParseAttlist) which parses the internal structures of an element or an attribute. Look at the whole sourceode to understand.

What's next??

Well, this article has shown you how easy it is to write a customizeable parser which can parse any kind of data - it's up to you, how complex it should be. The main benefit in using this kind of parsing is, that you don't need to incorporate in complex systems like LexParser.

Continue reading my second article:

Building an Easy-to-Use Parser/Parsing Framework (Part II)

Resize all controls when the parent form is resized

Problem/Question/Abstract:

How to resize all controls when the parent form is resized

Answer:

I would like to describe a technique I used in order to resize (with recursion) all the child controls of a TForm when the user resizes the form itself. I think it works relatively well, at least for my requirements. The key is the implementation of the OnResize event of the TForm. Every time the TForm is resized we chnage from an initial height PH to a final height HH and from an initial width PW to a final width WW.

At the very beginning (for example in the OnCreate event) we register the value of PW and PH:

Form1.FormCreate(Sender: TObject);
begin
  { ... }
  PW := Form1.ClientWidth;
  PH := Form1.ClientHeight;
  { ... }
end;

Then in the implementation of the OnResize event we have:

Form1.FormResize(Sender: TObject);
begin
  WW := Form1.ClientWidth; {new value of width after the resizing}
  HH := Form1.ClientHeight; {new value of height after the resizing}
  {put your cyclically resizing code here}
  {actual dimension: they will be the old dimensions in the next resizing }
  PW := WW;
  PH := HH;
end;

Now let's go deep into details with the cyclically resizing code. This is the code we place inside the implementation of the OnResize event of the TForm:

{ ... }
for I := 0 to (Form1.ControlCount - 1) do
begin
  ChangeDims(Form1.Controls[i], WW, PW, HH, PH);
end;

"ChangeDims" is the procedure which resizes (with recursion) the child controls.

procedure ChangeDims(Control: TControl; WW, PW, HH, PH: Integer);
var
  L, T, W, H: integer;
begin
  if Control is TWinControl then
    (Control as TWinControl).DisableAlign;
  try
    if Control is TWinControl then
      ScaleCtrls(Control as TWinControl, WW, PW, HH, PH);
    L := MulDiv(Control.Left, WW, PW);
    T := MulDiv(Control.Top, HH, PH);
    W := MulDiv(Control.Left + Control.Width, WW, PW) - L;
    H := MulDiv(Control.Top + Control.Height, HH, PH) - T;
    Control.SetBounds(L, T, W, H);
  finally
    if Control is TWinControl then
      (Control as TWinControl).DisableAlign;
  end;
end;

procedure ScaleCtrls(Control: TWinControl; WW, PW, HH, PH: Integer);
var
  I: Integer;
begin
  for I := 0 to Control.ControlCount - 1 do
    ChangeDims(Control.Controls[i], WW, PW, HH, PH);
end;

By making the above mentioned changes to your Form you can achieve the autoresizing of all child controls on a form. After verifing the validity of the code I encapsulated its functionality in a component. I didn't want to fill every time with extra code my form's implementation: I wanted to drop a component to my form and stop. This component assign the implementation of the OnResize event of the form after having assigned the aventually already present OnResize implementation. As a consequence the OnResize event of the Form will consist in the call to the user defined implementation (if any) followed by the above mentioned implementation which is responsible for the resizing. In this way you can assign your implementation to the OnResize event of the Form avoiding its hiding because of the presence of the cyclically resizing code.

Here is the complete code for the component:

unit Resize;

interface

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

type
  { THackControl = class(TControl); }

  TResize = class(TComponent)
  private
    { Private declarations }
    FForm1: TForm;
    PW, PH: integer;
    FOnResizeEvent: TNotifyEvent;
    procedure ScaleCtrls(Control: TWinControl; WW, PW, HH, PH: Integer);
    procedure ChangeDims(Control: TControl; WW, PW, HH, PH: Integer);
    procedure OnResizeEvent(Sender: TObject);
    procedure Resize();
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy(); override;
  published
    { Published declarations }
  end;

procedure Register;

implementation

constructor TResize.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if csDesigning in ComponentState then
    Exit;
  FForm1 := (Owner as TForm);
  PW := FForm1.ClientWidth;
  PH := FForm1.ClientHeight;
  if Assigned(FForm1.OnResize) then
  begin
    FOnResizeEvent := FForm1.OnResize;
  end;
  FForm1.OnResize := OnResizeEvent;
end;

destructor TResize.Destroy();
begin
  if not (csDesigning in ComponentState) then
    FForm1.OnResize := FOnResizeEvent;
  inherited Destroy();
end;

procedure TResize.ScaleCtrls(Control: TWinControl; WW, PW, HH, PH: Integer);
var
  I: Integer;
begin
  for I := 0 to Control.ControlCount - 1 do
    ChangeDims(Control.Controls[i], WW, PW, HH, PH);
end;

procedure TResize.ChangeDims(Control: TControl; WW, PW, HH, PH: Integer);
var
  L, T, W, H: integer;
begin
  if Control is TWinControl then
    (Control as TWinControl).DisableAlign;
  try
    if Control is TWinControl then
      ScaleCtrls(Control as TWinControl, WW, PW, HH, PH);
    L := MulDiv(Control.Left, WW, PW);
    T := MulDiv(Control.Top, HH, PH);
    W := MulDiv(Control.Left + Control.Width, WW, PW) - L;
    H := MulDiv(Control.Top + Control.Height, HH, PH) - T;
    { THackControl(Control).Font.Size := (PW div WW) * THackControl(Control).Font.Size;}
    Control.SetBounds(L, T, W, H);
  finally
    if Control is TWinControl then
      (Control as TWinControl).DisableAlign;
  end;
end;

procedure TResize.OnResizeEvent(Sender: TObject);
begin
  if Assigned(FOnResizeEvent) then
  begin
    FOnResizeEvent(Sender);
  end;
  Resize();
end;

procedure TResize.Resize();
var
  L, T, R, B, W, H, WW, HH, I: Integer;
begin
  WW := FForm1.ClientWidth;
  HH := FForm1.ClientHeight;
  for I := 0 to (FForm1.ControlCount - 1) do
  begin
    ChangeDims(FForm1.Controls[i], WW, PW, HH, PH);
  end;
  PW := WW;
  PH := HH;
end;

procedure Register;
begin
  RegisterComponents('Carlo Pasolini', [TResize]);
end;

end.

Implementing object persistence using streams

Problem/Question/Abstract:

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

Answer:

This question actually asks much more than just saving a list box at runtime. It brings to the surface some of the internal workings of Delphi itself. But I should clarify that what I present here does not deal with the workings of Delphi's Runtime Type Information (RTTI). That's probably best left for another article. But what I'm going to discuss is a practical way of implementing object persistence in your programs by using the saving the of a listbox at runtime as an example. Okay, here we go...

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

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

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

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

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

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

A simple example

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

unit main;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

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

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

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

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

end.

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

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

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

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

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

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

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

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

A demonstration program is available.

Color all controls on a form at runtime

Problem/Question/Abstract:

I want to color form controls at runtime without knowing beforehand how many and what controls there are.

Answer:

type
  TControlCracker = class(TControl);

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to ComponentCount - 1 do
    if Components[I] is TControl then
      TControlCracker(Components[I]).Color := clLime;
end;