How to save components to a file or stream (3)

Problem/Question/Abstract:

In D6, what's the best or usual way to stream an object to text so that it shows up just as it does when you copy an object to the clipboard or when you display a form as text?

Answer:

This example shows how to use the built-in VCL component streaming support to convert any component into a string and convert that string back into a component.

function ComponentToString(Component: TComponent): string;
var
  BinStream: TMemoryStream;
  StrStream: TStringStream;
  s: string;
begin
  BinStream := TMemoryStream.Create;
  try
    StrStream := TStringStream.Create(s);
    try
      BinStream.WriteComponent(Component);
      BinStream.Seek(0, soFromBeginning);
      ObjectBinaryToText(BinStream, StrStream);
      StrStream.Seek(0, soFromBeginning);
      Result := StrStream.DataString;
    finally
      StrStream.Free;
    end;
  finally
    BinStream.Free
  end;
end;

function StringToComponent(Value: string): TComponent;
var
  StrStream: TStringStream;
  BinStream: TMemoryStream;
begin
  StrStream := TStringStream.Create(Value);
  try
    BinStream := TMemoryStream.Create;
    try
      ObjectTextToBinary(StrStream, BinStream);
      BinStream.Seek(0, soFromBeginning);
      Result := BinStream.ReadComponent(nil);
    finally
      BinStream.Free;
    end;
  finally
    StrStream.Free;
  end;
end;

How to mix or separate three color channels

Problem/Question/Abstract:

I need to send a picture to 3 separate monochrome monitors in an embedded application I am writing. I could simply allow only one monitor to work at a time but thought it might be possible to drive the RGB outputs separately. This could be achieved by creating 3 pictures, one with red shades, one with green shades and one with blue shades and blending them together. I could do this by mixing the pictures pixel by pixel but suspect this would be extremely slow.

Answer:

But it's the only way (all other ways I can think of go back to the same). Use scanline and it is not that "extremely slow":

{ ... }
var
  Ptr1, Ptr2, Ptr3: ^Byte;
  PtrMix: ^Byte;
  X, Y: Integer;
begin
  for Y := 0 to Height - 1 do
  begin
    Ptr1 := RedBitmap.ScanLine[Y];
    Ptr2 := GreenBitmap.ScanLine[Y];
    Ptr3 := BlueBitmap.ScanLine[Y];
    PtrMix := MixBitmap.ScanLine[Y];
    for X := 0 to Width - 1 do
    begin
      PtrMix^ := Ptr1^;
      Inc(Ptr1);
      Inc(PtrMix);
      PtrMix^ := Ptr2^;
      Inc(Ptr2);
      Inc(PtrMix);
      PtrMix^ := Ptr3^;
      Inc(Ptr3);
      Inc(PtrMix);
    end;
  end;
end;

Make sure MixBitmap has 24 bit format, Red-, Green- and BlueBitmap have 8 bit format (or change the code for other formats). All bitmaps should have the same size (or use the smallest size for Width and Height).

Separating 3 color channels (instead of mixing) is very similar. Simply change PtrMix^ := Ptr1^; to Ptr1^ := PtrMix^; (and for the other channels, too).

Force a selection of cells in a TStringGrid

Problem/Question/Abstract:

I'm attempting to force a selection of cells based on the user clicking in the grid. Here is my code:

procedure TSizeSelectFrm.SizeSelectStrngGrdSelectCell(Sender: TObject;
  ACol, ARow: Integer; var CanSelect: Boolean);
var
  Select: TGridRect;
begin
  CanSelect := False;
  Select.Left := 0;
  Select.Right := 2;
  if ARow < 10 then
  begin
    Select.Top := ARow;
    Select.Bottom := SizeSelectStrngGrd.Selection.Bottom;
  end;
  if ARow > 10 then
  begin
    Select.Top := SizeSelectStrngGrd.Selection.Top;
    Select.Bottom := ARow;
  end;
  SizeSelectStrngGrd.Selection := Select;
end;

What happens is sometimes the selected cells don't always select properly. In the debugger, the value for select seems to be always set properly. Is there something wrong with the way I'm "applying" the selection?

Answer:

Your selection is overwritten when the mouse crosses a cell boundary or when the mouse button is released. SizeSelectStrngGrd.Selection. Right is made to correspond to the most recent cursor position. You can put it back like so:

procedure TForm1.SizeSelectStrngGrdMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Select: TGridRect;
begin
  {When the mouse button is released set the right of the selected range}
  Select := SizeSelectStrngGrd.Selection;
  Select.Right := 2;
  SizeSelectStrngGrd.Selection := Select;
  {Record that the mouse button is up}
  MouseDown := false;
end;

MouseDown is a class-scope Boolean that is used later. The mouse up handler above gives the right selection, but the grid looks naff as the selected area spreads out to the right then contracts when the mouse button is released. You can improve on that by recording whether the left mouse button is up or down:

procedure TForm1.SizeSelectStrngGrdMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  {Record that the mouse button is down}
  MouseDown := mbLeft = Button;
end;

and controlling how the grid is drawn so that cells you don't want to be selected are not drawn as though they were selected:

procedure TForm1.SizeSelectStrngGrdDrawCell(Sender: TObject;
  ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
  {When the mouse is down only allow cells in column two to be drawn as though they are selected}
  if ((ACol <> 2) and (gdSelected in State) and MouseDown) then
    State := State - [gdSelected];
  with SizeSelectStrngGrd.Canvas do
  begin
    {Choose a brush colour to suit the cell}
    if gdFixed in State then
      Brush.Color := clBtnFace
    else if gdSelected in State then
      Brush.Color := clHighlight
    else
      Brush.Color := clWindow;
    {Colour the cell background}
    FillRect(Rect);
    {Display the text}
    TextOut(Rect.Left + 2, Rect.Top + 2, SizeSelectStrngGrd.Cells[ACol, ARow]);
  end;
end;

This will likely need some polishing before it's ready for use, but it does let you control what is
selected.

How to change the caption of a MessageDlg

Problem/Question/Abstract:

How to change the caption of a MessageDlg

Answer:

Build your own:

function MyMessageDlg(const Msg: string; DlgType: TMsgDlgType; Buttons:
  TMsgDlgButtons;
  const ACaption: string = 'Hi'; DefaultButtonIndex: Integer = -1; HelpCtx: Longint =
    0): Integer;
var
  Index: Integer;
  ButtonIndex: Integer;
begin
  with CreateMessageDialog(Msg, DlgType, Buttons) do
  try
    HelpContext := HelpCtx;
    if ACaption <> '' then
      Caption := ACaption;
    if DefaultButtonIndex >= 0 then
    begin
      ButtonIndex := -1;
      for Index := 0 to ControlCount - 1 do
      begin
        if Controls[Index] is TButton then
        begin
          Inc(ButtonIndex);
          TButton(Controls[Index]).Default := ButtonIndex = DefaultButtonIndex;
          if ButtonIndex = DefaultButtonIndex then
            ActiveControl := TButton(Controls[Index]);
        end;
      end;
    end;
    Result := ShowModal;
  finally
    free;
  end;
end;

Refresh the Windows Desktop

Problem/Question/Abstract:

How can I refresh the Windows desktop after I have set a new background image in the registry?

Answer:

Solve 1:

I want to post this article because I sure that this question can ask a lot of developers but to find an answer is not easy task.

So if you need refresh a desktop in run-time, you can execute a next procedure:

uses ShlObj;
{...}
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, NULL, NULL);

This code will refresh a desktop image and re-read the icons for files with registered extentions.

PS: you can do a same if you press a right mouse button on desktop and select Update item.

Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, 106597, 0);
end;

This has the same effect as pressing F5 in Explorer.

Understanding what files are and choosing a Delphi file type - part 3

Problem/Question/Abstract:

What is a File? How are they stored? What format is best for my project? - The final part of a series by Philip Rayment

Answer:

The final example uses a simple text file for storage:

Example 3: Text File

procedure�WriteFile(filename:string);
var
��fil:�text;
��i:�integer;
begin���{WriteFile}
��AssignFile(fil,filename);�rewrite(fil);{Create the file}
  {Write the file version and number of records}
��Writeln(fil,LatestFileVersion,'�',length(People));[6]
��for�i:=0�to�high(people)�do
����with�people[i]�do�begin{Write the data}
������Writeln(fil,ChristianName);[6,10]
������Writeln(fil,Surname);[7,14]
������Writeln(fil,Address1);[21,9]
������Writeln(fil,Address2);[2,24]
������Writeln(fil,Town);[13,19]
������Writeln(fil,Postcode,'�',YearsService,'�',ID,'�',DateToStr(Birthdate)); [24,23]
����end;���{with}
��CloseFile(fil);
end;���{WriteFile}

procedure�ReadFile(filename:string);
var
��ver:�byte;
��i,�num:�integer;
��d:�string;
begin���{ReadFile}
��AssignFile(fil,filename);�reset(fil);��{Open the file}
��readln(fil,ver,num);{Read the version number and number of records}
��SetLength(people,num);
��for�i:=0�to�pred(num)�do
������with�people[i]�do�begin��{Read the data}
��������Readln(fil,ChristianName);
��������Readln(fil,Surname);
��������Readln(fil,Address1);
��������Readln(fil,Address2);
��������Readln(fil,Town);
��������Readln(fil,Postcode,YearsService,ID,d);
��������Birthdate:=StrToDate(d);
������end;���{with}
��CloseFile(fil);
end;���{ReadFile}

Analysis

The total file size is 178 bytes, not much more than the untyped file. Delphi automatically converts the numbers to text, but we have to use the DateToStr function to convert the date to text.

This table provides comparative statistics on the three examples:


Untyped files
Typed Files
Text Files
File size
143 bytes
342 bytes
178 bytes
Bytes in "header"
3
114
6
Average bytes per record
70
114
86
Lines of code in WriteFile()
28
12
17
Estimate of speed
Probably fairly fast, as no conversions were required, but there were many different calls to BlockWrite and several calls to a subroutine.
Probably fastest, as just three separate writes to the disk were involved.
Probably the slowest, due to all the conversions to text required.


The Advantages and disadvantages of the various file types are as follows:

Untyped Files

Advantages

You can store anything you wish in Untyped Files. There are no restrictions.
Untyped Files will normally be the most compact

Disadvantages

You have to keep track of the data yourself, which will normally require a fair bit of coding.

Typed Files

Advantages

Typed Files are easier to use than Untyped files.
Typed Files are probably the fastest for most purposes as the data can be loaded straight into the record. The other types usually involve more conversions and/or data shuffling.

Disadvantages

You are limited to one type of data per file.
Records have to be designed to hold the largest data (e.g. the longest possible name) and all records thus take up this space, so a Typed File is generally the most space hungry.
It is pointless writing pointers to the file (if you did, you would simply write and read the memory address, not the data itself), so you cannot have file of pointers, objects, or strings (longstrings) or records containing any of these. In any case the compiler will not allow a file of string (longstring).

Text Files

Advantages

Delphi has special facilities for handling Text Files, such as conversion of numerical data to text and vice versa, making Text Files easy to use and fairly compact.
Text Files can be viewed in a text editor or even dumped to the screen (or printer) at the command prompt with the TYPE command.
Corrupted files can be edited with a text editor.

Disadvantages

Non-textual data (other than numbers) cannot be included, unless somehow converted into a textual form.
Not efficient storage of non-textual data.

Appendix A

The following table compares how to code selected actions for various file types.


Untyped files
Typed Files
Text Files
Declaring
var
  f: file;
  v: type;
  i: integer;
var
  f: file of type;
  r: type;
  i: integer;
var
  f: TextFile;
  i: integer;
  s: string;
  ch: char;
Assigning
AssignFile(f, filename);
AssignFile(f, filename);
AssignFile(f, filename);
Opening for reading
FileMode := 0;
Reset(f, 1);
FileMode := 0;
Reset(f);
Reset(f);
Opening for reading and writing
Reset(f, 1);
Reset(f);
Not available
Opening for appending
Reset(f, 1);
Seek(f, filesize(f));
Reset(f);
Seek(f, filesize(f));
Append(f);
Creating
write(f, 1);
Rewrite(f);
Rewrite(f);
Reading
BlockRead(f, v, sizeof(v));
Read(f, r);
Read(f, i);
Read(f, s);
Readln(f, i, ch, s);(1)
Skip a record/line while reading
Seek(f, filepos(f) + sizeof(v));
Seek(f, succ(filepos(f)));
Readln(f);(2)
Writing
BlockWrite(f, v, sizeof(v));
Write(f, r);
Write(f, i);
Write(f, s);
Writeln(f, i, &#8216; &#8216;, s);(1)
Get the current file position
i := filepos(f);
i := filepos(f);
Not available
Jump to a position in the file
Seek(f, i);
Seek(f, i);
Not available
Get the file size
i := filesize(f);
i := filesize(f);
Not available (3)
Closing
CloseFile(f);
CloseFile(f);
CloseFile(f);


The Read, ReadLn, Write, and WriteLn procedures can take multiple arguments.
If the ReadLn procedure has no parameters (other than the file variable), the file pointer merely moves to the end of the line. If the WriteLn procedure has no parameters (other than the file variable), a blank line is output.
See the Tip "How do I get the size of a Text File in Delphi"?

Address Sort Order Index

Problem/Question/Abstract:

Address Sort Order Index

Answer:

The custom sort order is used to deal with the fact that the house and flat numbers are sorted as strings. They are stored as strings to allow things like '150-175' as a house number, or '3a', or perhaps even simply a flat 'A'.
The need for a custom sort order is caused by the fact that with an ordinary ASCII sort order '4' will appear after '30'. This is not desirable behaviour.

This approach to fix this problem is to look for the first number  in the string (if there is one) and then use this as some kind of  primary sort order. The rest of the sorting will then be done on  the remaining characters (with preceding and trailing spaces stripped out), based on the ASCII value of their upper - case varients. Potential problems caused by this approach include (but are not limited to) the use of accented characters will
possibly cause strange orderings and furthermore, if there is a block of flats with three floors A, B, C for example then supposing the flats on those floors are A1, A2, A3, B1, B2, B3 then the ordering of records will not be ideal - this approach will sort them as A1, B1, A2, B2, A3, B3. This behaviour is regrettable, but acceptable - we cannot tell that it is not flat A on floor 1 for example. It's unlikely that we will be able to find a sort order that always produces ideal results.

Some examples of sorted lists (not all ideal):

EXAMPLE 1
EXAMPLE 2
EXAMPLE 3






Flat 1
1
A
Flat 2
-2
B
3
2-4
C
3B
3a
1
Flat 3A
5
2


                
                            
                          
unit AddrSortOrder;

interface

uses SysUtils;

function CalcSortIndex(NumStr: string): double;

implementation

function CalcSortIndex(NumStr: string): double;
var
  strlength, i, j, tmp: integer;
  found: boolean;
  numpart, strpart, divisor: double;
  choppedstr: string;
begin
  //This function will return the sort index value for the string passed

  strlength := length(NumStr);
  if strlength = 0 then
  begin
    result := 0;
    exit;
  end;

  found := false;

  //split the string into a 'number' and a 'string' part..

  //initialise
  choppedstr := numstr;
  numpart := 0;

  //Locate the first digit (if there)
  for i := 1 to strlength do
  begin
    if numstr[i] in ['0'..'9'] then
    begin
      found := true; //First digit found!!
      break;
    end;
  end; //for i..

  if found then
  begin
    //now get the to the end of the digits..
    found := false;
    for j := i to strlength do
    begin
      if not (numstr[j] in ['0'..'9']) then
      begin
        found := true; //end of digits found
        break;
      end;
    end; //for j..

    //Separate out the string parts
    if found then
    begin
      //Number was embedded..
      val(copy(numstr, i, j - i), numpart, tmp);
      Delete(choppedstr, i, j - i);
    end
    else
    begin
      //Number went to the end of the string
      val(copy(numstr, i, strlength), numpart, tmp);
      Delete(choppedstr, i, strlength);
    end;
  end;

  choppedstr := Uppercase(trim(choppedstr));
  strlength := length(choppedstr);

  //evaluate a number for the remaining part of the string
  strpart := 0;
  divisor := 1;

  for i := 1 to strlength do
  begin
    divisor := divisor / 256;
    //convert from Char to single using a variant conversion
    strpart := strpart + (ord(choppedstr[i]) * divisor);
  end;

  //All done, return the value
  result := numpart + strpart;
end;

end.

Basic functions of the listbox explained

Problem/Question/Abstract:

I'm a beginner, how do i use the listbox??

Answer:

Ok heres some basic info on the listbox.
Their are many different functions to do with the listbox and it is not possible to display them all. So i am going to try and explain as many as possible.

Number 1, Lets start from the beginning.

OK so once you have placed the listbox you can add items at design time but to add them at runtime is a little more trick

make a form with one listbox, 1 button and 1 edit box

then add the following

in the button1 onclick method plave

listbox1.items.add(edit1.text);

this then adds the current text in the edit box onto the bottom of the list you can add as many items as you like until you exit the program.

Number 2, Taking it one step further.

Ok so you have a listbox now with a few items in it, but what if you want to add one of the items in at say line 3 instead of the bottom line. This can easily be achieved by amending the above code, by changing the 'add' to 'insert' and then adding an index refrence you can place it in at the desired line.

for example

listbox1.items.insert(3, edit1.text);

this will always then add the text from the edit box to the third line

Number 3, The rest.

Ok now you can get the total amount of items currently in a listbox by inserting the count procedure

showmessage('Current Number of lines := ' + inttostr(listbox1.items.count));

this will then display the message 'Current Number of Lines := ??' where ?? is a number.

Finally to get the currently selected item in the listbox you can add the following to the onclick method of your listbox

edit1.text := listbox1.items[listbox1.itemindex];

Position The Start-Button Anywhere On Your Taskbar

Problem/Question/Abstract:

Hiding/displaying/enabling and disabling the start button seems an old trick, try this new one
Start moving the start button on the taskbar !!

Answer:

Well, Start A New Project, And Give The Form The Next Properties

Align = top;
width = screen.width;

and then, OnMouseMove exent place the following code ....

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  p: tpoint;
begin
  getcursorpos(p);
  movewindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), x, y,
    25, 25, true);
end;

Run your application, when moving your mouse on your form, you will notice that the start button is minimized and is moving along with your mouse, with some more work, you can make this invisible to make the statr button move on a pre-schedueled event !!


Some More Information....

If you do the following, you will start to smile of what will happen on your desktop

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  p: tpoint;
begin
  getcursorpos(p);
  movewindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'ReBarWindow32', nil),
    x, y, 25, 25, true);
end;


Have Fun !!

Get the handle to the icon of a registered extension

Problem/Question/Abstract:

How can I get the icon of a registered extension (in the windows registry)?

Answer:

Solve 1:

First get the pointer to the operating systems image list and assign it to your own.

{Image List From System}
ImageListHandle := SHGetFileInfo('C:\', 0, FileInfo, SizeOf(FileInfo), SHGFI_SYSICONINDEX  or SHGFI_SMALLICON);
SendMessage(ListView1.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, LParam(ImageListHandle));

Then in your listview you can extract out the icon by doing this:

function GetShellIcon(FileName: string; Folder: Boolean): Integer;
var
  FileInfo: TSHFileInfo;
  ImageHandle: THandle;
  Flag: Integer;
begin
  if Folder then
    Flag := FILE_ATTRIBUTE_DIRECTORY
  else
    Flag := FILE_ATTRIBUTE_NORMAL;
  SHGetFileInfo(PChar(FileName), Flag, FileInfo, SizeOf(FileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_UseFileAttributes);
  Result := FileInfo.IIcon;
end;

Notice: At the bottom I assign the icon index from the IICON field of the data returned by SHGetFileInfo. So my function gets passed a filename and returns an image index. You could change the IICON field to the HICON field and then I believe you would be getting the handle to an icon.


Solve 2:

The SHGFI_SYSICONINDEX in the above code snippet is going to place the index of the icon in the system image list (a handle to which is being returned as the result of the SHGetFileInfo function call) in the FileInfo.iIcon member. Use the SHGFI_ICON flag instead to get an icon handle in HIcon.

function GetShellIcon(FileName: string; Folder: Boolean): Integer;
var
  FileInfo: TSHFileInfo;
  ImageHandle: THandle;
  Flag: Integer;
  IconHandle: THandle;
begin
  if Folder then
    Flag := FILE_ATTRIBUTE_DIRECTORY
  else
    Flag := FILE_ATTRIBUTE_NORMAL;
  SHGetFileInfo(PChar(FileName), Flag, FileInfo, SizeOf(FileInfo),
    SHGFI_ICON or SHGFI_SMALLICON or SHGFI_UseFileAttributes);
  Result := FileInfo.IIcon;
  IconHandle := FileInfo.HIcon;
end;


Solve 3:

One method of getting the associated icon with a particular file is to first populate an imagelist with registered system icons (this example is for small icons, you could do the same for large). In this example, iIndex will be the ImageList item for the particular file.

var
  dwSmallIcon: DWord;
  pFileInfo: TshFileInfo;
  iIndex: Integer;
begin
  dwSmallIcon := SHGetFileInfo('', 0, FileInfo, SizeOf(TshFileInfo), (SHGFI_ICON or
    SHGFI_SMALLICON or SHGFI_SYSICONINDEX));
  ImageList1.Handle := dwSmallIcon; {imagelist}
  ImageList1.ShareImages := True;
  FillChar(pFileInfo, SizeOf(TshFileInfo), 0);
  shGetFileInfo(pName, 0, pFileInfo, SizeOf(TshFileInfo), SHGFI_SYSICONINDEX or
    SHGFI_SMALLICON or SHGFI_OPENICON);
  iIndex := pFileInfo.iIcon;
end;

How to load, create and use (animated) cursors?

Problem/Question/Abstract:

Sometimes you have the need to use an animated cursor, for example when your applications are executing long operations.
This article explains how to load, create and use cursors (animated included).

Answer:

To use an animated cursor you have several options: load it from a file (using LoadImage or LoadCursorFromFile), load it from a resource (using LoadCursor) or even creating the cursor at runtime (using CreateCursor).

Note:
You should implement custom cursors as resources. Rather than create the cursors at run time, use the LoadCursor, LoadCursorFromFile, or LoadImage function to avoid device dependence, to simplify localization, and to enable applications to share cursor designs.

Loading a cursor from a file
  
The easiest way to load a cursor from a file is by using LoadCursorFromFile.
This functions returns a handle to the loaded cursor that you should assign to your application Cursors array.

var
  hCur: HCURSOR;

begin
  // Load the cursor from file
  hCur := LoadCursorFromFile(PChar('path_to_my_cursor'));
  // Assign the loaded cursor to application Cursors array. (This cursor will ave the
  // number 1 assigned to it
  // Remember that predefined cursors start at a negative index, and user defined
  // custom cursors are assigned positive indexes.
  Screen.Cursors[1] := hCur;

  // Use the cursor as you would use a built-in cursor.
  Screen.Cursor := 1;
end;

You can also use LoadImage instead of LoadCursorFromFile like this:  

  hCur := LoadImage(0, PChar(PChar('path_to_my_cursor')), IMAGE_CURSOR, 0, 0,
  LR_DEFAULTSIZE or LR_LOADFROMFILE);
    
Loading a cursor from a resource

Before loading a cursor from a resource it's necessary to create the resource file with the cursor to be loaded.

To do this create a file myResources.rc where you'll put the following

#define ANICURSOR 21
myCursor ANICURSOR "path_to_my_cursor"

Because Borland's resource compiler does not understand the ANICURSOR resource type, so you have to use the numeric id (21).
Compile your resource file using "brcc32 myResources.rc" and include in the unit where you'll be loading the cursor, using {$R myResources.res}

Now, you just have to load the cursor from the resource instead of loading it from a file, using:

hCur := LoadCursor(HInstance, PChar('myCursor'));
  
Remember that HInstance contains the instance handle of the application or library as provided by Windows. This variable it's very importante because it's the one used with many Windows API that work with current application resources.
  
Creating a cursor at runtime
  
Another way to use a cursor it's creating one at runtime. Why would you do that?
I don't know, it's your choice. I doubt you ever will create your cursors at runtime, anyway here it's way how to do it.

Define the cursor map

const
  // Yin cursor AND bitmask
  ANDmaskCursor: array[0..127] of byte = (
    $FF, $FC, $3F, $FF, $FF, $C0, $1F, $FF,
    $FF, $00, $3F, $FF, $FE, $00, $FF, $FF,
    $F7, $01, $FF, $FF, $F0, $03, $FF, $FF,
    $F0, $03, $FF, $FF, $E0, $07, $FF, $FF,
    $C0, $07, $FF, $FF, $C0, $0F, $FF, $FF,
    $80, $0F, $FF, $FF, $80, $0F, $FF, $FF,
    $80, $07, $FF, $FF, $00, $07, $FF, $FF,
    $00, $03, $FF, $FF, $00, $00, $FF, $FF,
    $00, $00, $7F, $FF, $00, $00, $1F, $FF,
    $00, $00, $0F, $FF, $80, $00, $0F, $FF,
    $80, $00, $07, $FF, $80, $00, $07, $FF,
    $C0, $00, $07, $FF, $C0, $00, $0F, $FF,
    $E0, $00, $0F, $FF, $F0, $00, $1F, $FF,
    $F0, $00, $1F, $FF, $F8, $00, $3F, $FF,
    $FE, $00, $7F, $FF, $FF, $00, $FF, $FF,
    $FF, $C3, $FF, $FF, $FF, $FF, $FF, $FF
    );

  // Yin cursor XOR bitmask
  XORmaskCursor: array[0..127] of byte = (
    $00, $00, $00, $00, $00, $03, $C0, $00,
    $00, $3F, $00, $00, $00, $FE, $00, $00,
    $0E, $FC, $00, $00, $07, $F8, $00, $00,
    $07, $F8, $00, $00, $0F, $F0, $00, $00,
    $1F, $F0, $00, $00, $1F, $E0, $00, $00,
    $3F, $E0, $00, $00, $3F, $E0, $00, $00,
    $3F, $F0, $00, $00, $7F, $F0, $00, $00,
    $7F, $F8, $00, $00, $7F, $FC, $00, $00,
    $7F, $FF, $00, $00, $7F, $FF, $80, $00,
    $7F, $FF, $E0, $00, $3F, $FF, $E0, $00,
    $3F, $C7, $F0, $00, $3F, $83, $F0, $00,
    $1F, $83, $F0, $00, $1F, $83, $E0, $00,
    $0F, $C7, $E0, $00, $07, $FF, $C0, $00,
    $07, $FF, $C0, $00, $01, $FF, $80, $00,
    $00, $FF, $00, $00, $00, $3C, $00, $00,
    $00, $00, $00, $00, $00, $00, $00, $00
    );    

then create the cursor

hCur := CreateCursor(HInstance, 19, 2, 32, 32, @ANDmaskCursor, @XORmaskCursor);
  
For an example see the attached sample.

Accessing a TForm from a package

Problem/Question/Abstract:

I have a package which contains a form and some units. I want to be able to load that form into a main application but I have no idea how to do it does anyone have some example code I can look at?

Answer:

There are two ways to use packages: statically bound or dynamically loaded. This is similar to DLLs. To bind a package statically to your project you name it in the projects package list and build the project with run-time packages.
To use something from the package you simply add the unit that contains the something to a uses clause as if it were part of the project. The linker takes care of making sure the unit is not compiled into the project but linked in from the package at run-time. In this scenario the code using the package is completely unaware that the stuff it uses comes from a package.

Dynamically loaded packages are somewhat more complex to use. The following is an excerpt from an older reply on how to put MDI children into packages. Note that you need to build the host app with run-time packages, you just use only the standard set of packages, do not name the packages you want to load dynamically in the package list.

Quote:

If you load them dynamically via LoadPackage the main program typically gets a list of available child form packages from somewhere, e.g. from an INI file, a registry key, or simply by scanning a folder at a known location for BPL files. Each package is required to export a set of functions with known names (perhaps only one). You export functions from a package the same way you do it from a DLL, via an exports clause. And you get these entry points from your main program also the same way you do it for DLLs, via GetProcAddress. So each child form package would export a function

function CreateChild: TForm;

The main app can now create child forms just by calling this function for each childform package. Whether it uses the returned reference is up to the program, it can get references to the child forms from mainform.MDIChildren if it needs them. Each child form in turn is required to implement a specific interface which the main form can use to communicate with it. This interface can be message-based, or it can be an actual Interface (non-COM) which the main form can obtain by sending a specific user message to the child form. This way the main form needs to know no details about the child forms, so has no need to Use the child forms unit.

If you don't load the packages dynamically you can still remove the dependence on the child form units completely. In this case the CreateChild method would be something the package exports in a unit (one unit per package, it may contain only this one function) and the main form would Use this unit from each of the packages. This is of course not very maintenance-friendly, there are other ways to manage this, e.g. by using a central registration mechanism (implemented in a common package) into which each of the child packages can register its CreateChild function together with the package name. The main form could then ask this registry to create a child for a given package. If the main form reads the list of packages from some file this would make your package set extensible without requiring any change to the main form when you add a new one.

Change the project default directory

Problem/Question/Abstract:

Change the project default directory

Answer:

The project default directory is

\Borland\Delphi 3.0\Bin

which annoys me regularly.

This setting can be changed via right-click on the Delphi program icon:
"Properties" -> page "Shortcut", field "Start in:"

Here you may enter your default - project directory.

How to get the control identifier of Windows dialogs

Problem/Question/Abstract:

How can I get the identifier of a given control, which is part of a predefined windows dialog such as open/ save dialogs? I need to alter text in the edit control and/ or alter captions on buttons before the dialog closes. Can this be accomplished with API calls and/ or messages to the dialog in question?

Answer:

With WinSight for example. Anyway, there are some of them (Open/ Save dialog controls ID's):

"Look in" - ID 1137 , classname "ComboBox"
"Files of type" - ID 1136 , classname "ComboBox"
"File Name" - ID 1152 , classname "Edit"
"Help" - ID 1038 , classname "Button"
"Open" - ID 1 , classname "Button"
"Cancel" - ID 2 , classname "Button"
"Open as Read only" - ID 1040 , classname "Button"

The usage - for example, to alert the text of "File name" Edit - is like this:

{ ... }
var
  MyText: string;
begin
  MyText := 'Hello!';
  SendMessage(Windows.GetParent(Self.Handle), CDM_SETCONTROLTEXT,
    1152, Integer(PChar(MyText)));
  { ... }

How to execute a console application from a Delphi program

Problem/Question/Abstract:

How to execute a console application from a Delphi program

Answer:

This executes a console application, but if your application is not a console, just remove CREATE_NEW_CONSOLE.

function RunApp(const aCmd: string; aWait: boolean; aShowMode: integer): DWORD;
var
  StartUpInfo: TStartUpInfo;
  ProcessInfo: TProcessInformation;
  WaitCode: DWORD;
begin
  Result := 0;
  ZeroMemory(@StartupInfo, SizeOf(TStartupInfo));
  StartUpInfo.cb := SizeOf(StartUpInfo);
  StartUpInfo.wShowWindow := aShowMode;
  StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
  ZeroMemory(@ProcessInfo, SizeOf(TProcessInformation));
  Win32Check((CreateProcess(nil, PChar(aCmd), nil, nil, False, CREATE_NEW_CONSOLE +
    NORMAL_PRIORITY_CLASS, nil, nil, StartUpInfo, ProcessInfo)));
  try
    if aWait then
    begin
      repeat
        WaitCode := WaitForSingleObject(ProcessInfo.hProcess, 10000);
        Win32Check(WaitCode < > WAIT_FAILED);
        if WaitCode = WAIT_TIMEOUT then
        begin
          if MessageDlg('This is a test', mtWarning, [mbYes, mbNo], 0) < > mrYes then
            Break;
        end
        else
          Break;
      until
        False;
      Win32Check(GetExitCodeProcess(ProcessInfo.hProcess, Result));
    end;
  finally
    CloseHandle(ProcessInfo.hThread);
    CloseHandle(ProcessInfo.hProcess);
  end;
end;

How to create user-defined messages in a TThread

Problem/Question/Abstract:

I try to build a thread that I can send a message to order to stop. I know that messages are normally used for screen object but the thread is also having a handle. I 'd like to be able to send a message to this thread and having the sender waiting until the stop is confirmed. (or something that's equivalent)

Answer:

A thread has a handle, but it is not a window handle, so you cannot send a message to it with SendMessage. There is a PostThreadMessage API function that can be used to send a message to the thread itself. But to receive it the thread needs a message loop, which threads normally don't have.

If your thread is permanently slaving away in a work loop and you want to stop it just set a boolean field declared in the thread object to true (this is what Thread.Terminate does, for example). The work code inside the thread has to check this field regularly to detect that it has been set, and then exit the loop.

If the thread is waiting on something and you want to wake it up you have to modify the wait code so that it uses WaitforMultipleObjects, one of which is an event object you can signal from outside to wake the thread up.

Here is an example for this technique:


{Writing an interruptible timer thread}

unit Unit1;

interface

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

type
  TTimerThread = class;
  TWakeupKind = (wkTimerExpired, wkEventTriggered);
  TWaitState = (wsIdle, wsWaiting);
  TWakeupEvent = procedure(sender: TTimerThread; reason: TWakeupKind) of object;
  TTimerThread = class(TThread)
  private
    FInterval: DWORD;
    FReason: TWakeupKind;
    FEvent: THandle;
    FState: TwaitState;
    FWakeupEvent: TWakeupEvent;
    FNoWakeupEvent: Boolean;
    procedure SyncWakeup;
  protected
    procedure DoWakeup;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
    procedure Execute; override;
    procedure Sleep(forInterval: DWORD);
    procedure Wakeup;
    procedure Terminate;
    property OnWakeup: TWakeupEvent read FWakeupEvent write FWakeupEvent;
    property Interval: DWORD read FInterval write FInterval;
    property State: TWaitState read FState;
  end; {TTimerThread}

  TForm1 = class(TForm)
    StatusBar: TStatusBar;
    WaitButton: TButton;
    OpenDialog1: TOpenDialog;
    Label1: TLabel;
    WaitIntervalEdit: TEdit;
    WakeupButton: TButton;
    Memo1: TMemo;
    procedure WaitIntervalEditKeyPress(Sender: TObject; var Key: Char);
    procedure WaitButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure WakeupButtonClick(Sender: TObject);
  private
    { Private declarations }
    FTimerthread: TTimerThread;
    procedure TimerWakeup(sender: TTimerThread; reason: TWakeupKind);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses typinfo;

{$R *.DFM}

procedure TForm1.WaitIntervalEditKeyPress(Sender: TObject; var Key: Char);
begin
  if not (key in ['0'..'9', #8]) then
    Key := #0;
end;

procedure TForm1.WaitButtonClick(Sender: TObject);
begin
  FTimerThread.Sleep(StrToInt(WaitIntervalEdit.Text));
  memo1.lines.add('Timer started');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FTimerthread := TTimerThread.Create;
  FTimerthread.FreeOnTerminate := true;
  FTimerthread.OnWakeup := TimerWakeup;
end;

procedure TForm1.TimerWakeup(sender: TTimerThread; reason: TWakeupKind);
begin
  memo1.lines.add('Timer woke up, reason: ' + GetEnumName(Typeinfo(TWakeupKind),
    Ord(reason)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Assigned(FTimerthread) then
    FTimerThread.Terminate;
end;

procedure TForm1.WakeupButtonClick(Sender: TObject);
begin
  FTimerthread.Wakeup;
end;

{ TTimerThread }

constructor TTimerThread.Create;
begin
  {create thread suspended}
  inherited Create(true);
  {create event object}
  FEvent := CreateEvent(
    nil, {use default security}
    true, {event will be manually reset}
    false, {event starts out not signaled}
    nil); {event has no name}
  if FEvent = 0 then
    raise Exception.CreateFmt('TTimerThread.Create: could not create API event
      handle. '#13#10' %s', [ Syserrormessage( GetLastError ) ] );
      {thread will stay suspended until started by a Sleep or Resume call}
      FState := wsIdle;
      FNoWakeupEvent := False;
end;

destructor TTimerThread.Destroy;
begin
  inherited;
  if FEvent <> 0 then
    CloseHandle(FEvent);
end;

procedure TTimerThread.DoWakeup;
begin
  {called in threads context to fire OnWakeup event}
  if Assigned(FWakeupEvent) and not FNoWakeupEvent then
    Synchronize(SyncWakeup);
end;

procedure TTimerThread.Execute;
var
  res: DWORD;
begin
  {Executes inside threads context}
  repeat
    Fstate := wsWaiting;
    res := WaitForSingleObject(FEvent, FInterval);
    if res = WAIT_OBJECT_0 then
    begin
      FReason := wkEventTriggered;
      ResetEvent(FEvent);
    end
    else
      FReason := wkTimerExpired;
    DoWakeup;
    if not Terminated then
    begin
      Fstate := wsIdle;
      Suspend;
    end;
  until
    Terminated;
end;

procedure TTimerThread.Sleep(forInterval: DWORD);
begin
  {called from outside threads context to start thread sleeping}
  Interval := forInterval;
  if State <> wsIdle then
  begin
    {thread is already waiting. Wake it up but disable wakeup event}
    FNoWakeupEvent := true;
    try
      Wakeup;
      while State = wsWaiting do
        Windows.Sleep(10);
    finally
      FNoWakeupEvent := false;
    end;
  end;
  Resume;
end;

procedure TTimerThread.SyncWakeup;
begin
  {executes in main threads context}
  {Note: FWakeupevent has already been checked to be <> nil in DoWakeup}
  FWakeupEvent(self, FReason);
end;

procedure TTimerThread.Terminate;
begin
  inherited Terminate;
  {in case thread is waiting, don't fire Wakeup event on wakeup}
  FNoWakeupEvent := true;
  Wakeup;
end;

procedure TTimerThread.Wakeup;
begin
  {executes in callers thread context}
  if State = wsWaiting then
    SetEvent(FEvent);
end;

end.

How to blend two TBitmap's (3)

Problem/Question/Abstract:

I was wondering how I could overlay/ transpose an image over another while taking account the transparent background. Basically, what I want to do is to allow my client to place a transparent logo (an overlay image) unto their other image. Each time I tried to do that, I keep getting the rectangular background.

Answer:

Here is some code to merge two bitmaps. It is not exactly what you are looking for, but it is a place to start. You would need to check for the transparency color and skip those pixels and only operate on the rect of the smaller bitmap.

{ ... }
MaxPixelCount = 65536;

type
  TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
  pRGBArray = ^TRGBArray;

function MergeBitmap(const BitmapA: TBitmap; const WeightA: Cardinal;
  const BitmapB: TBitmap; const WeightB: Cardinal): TBitmap;
var
  i, j: Integer;
  RowA: pRGBArray;
  RowB: pRGBArray;
  RowTween: pRGBArray;
  SumWeights: Cardinal;

  function WeightPixels(const pixelA, pixelB: Cardinal): Byte;
  begin
    Result := Byte((WeightA * pixelA + WeightB * pixelB) div SumWeights)
  end;

begin
  SumWeights := WeightA + WeightB;
  Result := TBitmap.Create;
  Result.Width := BitmapA.Width;
  Result.Height := BitmapA.Height;
  Result.PixelFormat := pf24bit;
  if WeightA = 0 then
    Result.Canvas.Draw(0, 0, BitmapB)
  else if WeightB = 0 then
    Result.Canvas.Draw(0, 0, BitmapA)
  else if SumWeights > 0 then
  begin
    for j := 0 to Result.Height - 1 do
    begin
      RowA := BitmapA.Scanline[j];
      RowB := BitmapB.Scanline[j];
      RowTween := Result.Scanline[j];
      for i := 0 to Result.Width - 1 do
      begin
        with RowTween[i] do
        begin
          rgbtRed := WeightPixels(rowA[i].rgbtRed, rowB[i].rgbtRed);
          rgbtGreen := WeightPixels(rowA[i].rgbtGreen, rowB[i].rgbtGreen);
          rgbtBlue := WeightPixels(rowA[i].rgbtBlue, rowB[i].rgbtBlue)
        end;
      end;
    end;
  end;
end;

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)