Setting the invisible color of a transparent image

Problem/Question/Abstract:

How can I set the invisible color of a transparent image to other than the pixel in the lower-left corner?

Answer:

Transparent image

The TImage component has a Transparent property that when set to True displays the bitmap of the Picture property transparently. To do this, it takes the color of the bottom-leftmost pixel and treates all pixels of this color as invisible (you can see the objects begind the TImage). For example, this bitmap...

                GGGGGGGGG
                GRRRRRRRG
                GRRRRRRRG
                GRRRRRRRG
                GGGGGGGGG

...would be seen this way:


                 RRRRRRR
                 RRRRRRR
                 RRRRRRR


Since the pixel of the lower-left corner is green (G), all green pixels are made invisible. But, what if we wanted to see the image this way?

                GGGGGGGGG
                G       G
                G       G
                G       G
                GGGGGGGGG

TransparentColor and TransparentMode

To achieve this result, we have to set the TransparentColor and TransparentMode properties of the bitmap at run-time, for example when the form is created:

procedure TForm1.FormCreate(Sender: TObject);
begin
  with Image1.Picture.Bitmap do
  begin
    TransparentColor := clMaroon;
    TransparentMode := tmFixed;
  end;
end;

TransparentColor is the color (Color) that will be considered invisible. For example, we can use a constant (like $00800000, clMaroon or clBtnFace) or we can get the color from some pixel of the bitmap (like Canvas.Pixels[1,1]). TransparentMode is tmAuto by default, meaning it takes the color of the pixel in the lower-left
corner, and we have to set it to tmFixed (the other possible value) to tell the bitmap to use the color stored in the TransparentColor property as the invisible color.


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

Graying Bitmaps and Graphics

Problem/Question/Abstract:

This article shows how to gray a color bitmap. It reduces true-color bitmaps to 256 shades of gray paletted bitmaps, which reduces memory requirements.
The article also provides a function for graying any TGraphic descendant which is assignable to a TBitmap (or who knows how to assign itself to one: AssignTo method)

Answer:

After a while without posting I've came up with this article which explores a simple yet (non)colorful subject: changing color images to gray scale.

Writting a function to do that is easy: one could simply get a bitmap, promote it to 32 or 24 bit true-color, and then get the pixel components, one by one, and change them to the arithmetic avarage (red+green+blue component div 3) for every pixel. Something like:

Bitmap.PixelFormat := pf24Bit;
for y := 0 to Bitmap.Height - 1 do
  for x := 0 to Bitmap.Width div 3 do
  begin
    C := PChar(ScanLine[y])[x * 3] + PChar(ScanLine[y])[x * 3 + 1] +
      PChar(ScanLine[y])[x * 3 + 2] div 3;
    FillChar(PChar(SCanLine[y])[x * 3], 3, C);
  end;

And you will get a grayed bitmap wich is stored as a 24 bit depth true-color picture. What a wast of space and memory... (Attention: I didn't tested the above code, it is much more an algorithm than an implementation... I've written it directly here while writting the article :-)

But using this technique is not a good approach! First, every grayscale image can only have 256 shades of gray in current Windows based computers, since the Red, Green and Blue component each can only vary from 0 to 255. A gray scale image is one where R=G=B, so there can only be 256 possible levels of gray (or intensity). So using true color images to store a gray one is waste of space.

The code bellow in an excerpt from my work on progress DGL (Delphi Graphics Library), which I think I will never finish due to my load on work and at home (I am a Jiu-Jitsu fighter and have to attend to the trainning every day!!!! :-). This code was encapsulated in one filter class (TGrayFilter), because the DGL uses filters to apply effects and transformations on images. Here I've stripped the object orientation completely and wrote two simple functions to do it for you.

It is supposed that you have some familiarity with Bitmap scanlines to fully understand what is going on, and with the methods I use here to manipulate Scanlines. If you didn't have that knowledge, you could take a look at my article "BitmapToRegion (Delphi-like version - very fast) (UPDATE: Bug fix!)", Article # 944. There I enter in more detail about Scanlines and the methods I will use here.


The project bellow is very simple. To test it all you need to do is to save the DFM (which I suplly in text format) by copying and pasting in Notepad and saving the file as Unit1.dfm. After that open the form in Delphi and copy and past the code bellow in the entire unit. After that add this unit to a project and run it.

---- CODE -----

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    btnOpen: TBitBtn;
    OpenPic: TOpenPictureDialog;
    btnGrayBitmap: TBitBtn;
    btnGrayGraphic: TBitBtn;
    procedure btnOpenClick(Sender: TObject);
    procedure btnGrayBitmapClick(Sender: TObject);
    procedure btnGrayGraphicClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ general routines - They are in a separate unit in my on progress Delphi
  Graphics Library, but for this example I will put them here }

procedure GetScanLineProperties(Bitmap: TBitmap; var Start: Pointer;
  var Dif: Integer);
begin
  Start := Bitmap.ScanLine[0];
  if Bitmap.Height > 1 then
    Dif := Integer(Bitmap.ScanLine[1]) - Integer(Start)
  else
    Dif := 0;
end;

function BuildGrayPalette(PixelFormat: TPixelFormat): HPalette;
var
  Pal: TMaxLogPalette;
  i, step: Integer;
  C: Integer;
begin
  Pal.palVersion := $300;
  step := 1;
  case PixelFormat of
    pf1bit: step := 255;
    pf4bit: step := 16;
    pf8bit: step := 1;
  end;
  if step < 255 then
    Pal.palNumEntries := 256 div step
  else
    Pal.palNumEntries := 2;
  if PixelFormat = pf4bit then
  begin
    C := step - 1;
    for i := 0 to Pal.palNumEntries - 1 do
    begin
      FillChar(Pal.palPalEntry[i], 3, C);
      Pal.palPalEntry[i].peFlags := 0;
      Inc(C, step);
    end;
  end
  else
  begin
    C := 0;
    for i := 0 to Pal.palNumEntries - 1 do
    begin
      FillChar(Pal.palPalEntry[i], 3, C);
      Pal.palPalEntry[i].peFlags := 0;
      Inc(C, step);
    end;
  end;
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

function GrayPaletteEntries(Pal: HPALETTE): HPALETTE;
var
  PaletteSize: Cardinal;
  LogPal: TMaxLogPalette;
  i: Integer;
begin
  Result := 0;
  if Pal = 0 then
    Exit;
  PaletteSize := 0;
  if GetObject(Pal, SizeOf(PaletteSize), @PaletteSize) = 0 then
    Exit;
  if PaletteSize = 0 then
    Exit;
  with LogPal do
  begin
    palVersion := $0300;
    palNumEntries := PaletteSize;
    GetPaletteEntries(Pal, 0, PaletteSize, palPalEntry);
    for i := 0 to palNumEntries - 1 do
      FillChar(palPalEntry[i], 3, (palPalEntry[i].peRed +
        palPalEntry[i].peGreen +
        palPalEntry[i].peBlue) div 3);
  end;
  Result := CreatePalette(PLogPalette(@LogPal)^);
end;

procedure GrayBitmap(Bitmap: TBitmap);
var
  Dest: TBitmap;
  SrcRow, DstRow: PByteArray;
  DstDif, SrcDif, x, y, bpp: Integer;
begin
  GetScanLineProperties(Bitmap, Pointer(SrcRow), SrcDif);
  case Bitmap.PixelFormat of
    { palette - need only to gray the palette entries }
    pf1Bit, pf4Bit, pf8Bit:
      begin
        Bitmap.Palette := GrayPaletteEntries(Bitmap.Palette);
      end;
    { true color - will reduce to 8-bit palette (slower but saves memory) }
    pf15Bit, pf16Bit:
      begin
        raise
          Exception.Create('Not implemented! I am tired! Try promoting the bitmap to pf24/32bit before calling the function!');
      end;
    pf24Bit, pf32Bit:
      begin
        Dest := TBitmap.Create;
        try
          Dest.PixelFormat := pf8Bit;
          Dest.Width := Bitmap.Width;
          Dest.Height := Bitmap.Height;
          Dest.Palette := BuildGrayPalette(pf8bit);
          GetScanLineProperties(Dest, Pointer(DstRow), DstDif);
          if Bitmap.PixelFormat = pf24bit then
            bpp := 3
          else
            bpp := 4;
          for y := 0 to Pred(Bitmap.Height) do
          begin
            for x := 0 to Pred(Bitmap.Width) do
              DstRow[x] := (SrcRow[x * bpp] + SrcRow[x * bpp + 1] + SrcRow[x * bpp +
                2]) div 3;
            Inc(Integer(SrcRow), SrcDif);
            Inc(Integer(DstRow), DstDif);
          end;
          Bitmap.Assign(Dest);
        finally
          Dest.Free;
        end;
      end;
  end;
end;

procedure GrayGraphic(Graphic: TGraphic);
var
  Work: TBitmap;
begin
  Work := TBitmap.Create;
  try
    // the majority of TGraphic class knows how to assign itself to bitmaps (method AssignTo)
    Work.Assign(Graphic);
    if Work.PixelFormat in [pf15Bit, pf16Bit] then
      Work.PixelFormat := pf32Bit; // 32-bit bitmaps are the fastest true color
    GrayBitmap(Work);
    Graphic.Assign(Work);
    Graphic.Modified := True;
  finally
    Work.Free;
  end;
end;

{ TForm1 }

procedure TForm1.btnOpenClick(Sender: TObject);
begin
  if OpenPic.Execute then
    Image1.Picture.LoadFromFile(OpenPic.FileName);
end;

procedure TForm1.btnGrayBitmapClick(Sender: TObject);
begin
  GrayBitmap(Image1.Picture.Graphic as TBitmap);
end;

procedure TForm1.btnGrayGraphicClick(Sender: TObject);
begin
  GrayGraphic(Image1.Picture.Graphic);
end;

end.

---- FORM AS TEXT ----- COPY AND PAST IT TO NOTEPAD AND SAVE AS UNIT1.DFM -----

object Form1: TForm1
  Left = 290
    Top = 129
    Width = 696
    Height = 480
    Caption = 'Form1'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    PixelsPerInch = 96
    TextHeight = 13
    object Image1: TImage
    Left = 88
      Top = 8
      Width = 225
      Height = 209
      AutoSize = True
  end
  object btnOpen: TBitBtn
    Left = 8
      Top = 8
      Width = 75
      Height = 25
      Caption = '&Open Picture'
      TabOrder = 0
      OnClick = btnOpenClick
  end
  object btnGrayBitmap: TBitBtn
    Left = 8
      Top = 40
      Width = 75
      Height = 25
      Caption = '&Gray Bitmap'
      TabOrder = 1
      OnClick = btnGrayBitmapClick
  end
  object btnGrayGraphic: TBitBtn
    Left = 8
      Top = 72
      Width = 75
      Height = 25
      Caption = '&Gray Graphic'
      TabOrder = 2
      OnClick = btnGrayGraphicClick
  end
  object OpenPic: TOpenPictureDialog
    Left = 32
      Top = 136
  end
end

The form has three buttons. The first will load a picture and show it in the Image control. The second will try to gray the graphic stored in the picture property of the TImage as if it was a Bitmap (it will fail if it isn't a Bitmap). And the third will call the GrayGraphic which will work for bitmaps and other compatible TGraphic descendants.

Try to load Jpegs to see taht the code work even with other TGraphics. If you have other third-party supplied, and fully working TGraphic descendant, try adding them to the unit1 (TGifImage for example), and you'll see that it also works with them.

I hope that you can get some good things out of this article (ScanLine manipulation, bitmap format information, TGraphic relationships, etc.) or that it proves useful to you.

How to save and load a TList with records and TStrings objects

Problem/Question/Abstract:

I know how to load and save following like records in a TList container with filestream, but how can I load and save records like this:

TClassRec = record
  classname: string[10];
  pupils: TStringlist; // which contains the ID-strings of each pupil
end;

Answer:

Pupils in an instance of the record above contains only a Pointer, the address of the actual object, and saving that is worse than useless. You need to add code to save the objects data. I would create a TWriter for the stream, that makes life a bit easier:


Stream := TFileStream.Create(Filename, fmCreate);
try
  Writer := TWriter.Create(Stream, 4096);
  try
    writer.WriteInteger(Classlist.Count);
    for I := 0 to ClassList.Count - 1 do
    begin
      ClassRec := ClassList[i];
      Writer.WriteString(classrec^.classname);
      Writer.WriteString(classrec^.pupils.text);
    end;
  finally
    Writer.Free;
  end;
finally
  Stream.Free
end;

    
The reading part needs to be modified accordingly, using a TReader in this case.


Stream := TFileStream.Create(Filename, fmOpenread or fmShareDenyWrite);
try
  Reader := TReader.Create(Stream, 4096);
  try
    numRecords := Reader.readInteger;
    for I := 1 to numRecords do
    begin
      New(classrec);
      classrec^.classname := Reader.readString;
      classrec^.pupils := TStringlist.Create;
      classrec^.pupils.text := Reader.readString;
      Classlist.Add(classrec);
    end;
  finally
    Reader.Free;
  end;
finally
  Stream.Free
end;

How to control the hint position

Problem/Question/Abstract:

How do I force hints to be shown where I want? The hint for a stringgrid currently is showing up right below it, where it doesn't get noticed if the user is moving his/ her mouse over the top of the grid and the grid is large. Ideally I'd want that little yellow boxed hint to show as close to the cursor as possible.

Answer:

procedure TArrangerForm.AppShowHint(var HintStr: string; var CanShow: Boolean;
  var HintInfo: THintInfo);
var
  i: integer;
begin
  with HintInfo do
  begin
    if (HintControl = LocatorPanel1) then
      with LocatorPanel1 do
      begin
        if not (csLButtonDown in ControlState) then
        begin
          i := FindListMarker(CursorPos.X);
          if (i >= 0) then
          begin
            HintPos := ClientToScreen(Point(TimeToPixel(MarkerList.Markers[i].Offset) + 10, 2));
            Application.HintPause := 0;
            Application.HintHidePause := MaxInt;
            CanShow := True;
            exit;
          end;
        end;
        CanShow := False;
      end;
  end;
  Application.HintPause := 800;
  Application.HintHidePause := 2500;
end;

Migrating a Delphi installation/settings storage

Problem/Question/Abstract:

I have to move my Delphi installation to a new disk. I installed Windows and Delphi. Then I copied the entire Borland directory from the old drive. Delphi appeared in its default colors and settings. Which settings are stored where (default compile settings, directories, etc.)?

Answer:

Depends on which settings you are looking for. Some are in defProj.dof, some in defProj.dsk for new projects, myproject.dof, .dsk, .dsm for existing projects. And others are in the registry, mostly in CurrentUser, but a few in LocalMachine as well. Some are in the .res file and the .cfg file as well.
Your default compile settings would best be moved by getting the defProj.dof file from the delphi\bin directory, but the library paths will be in the registry under the library key.

How to draw on the frame of a TForm

Problem/Question/Abstract:

How to draw on the frame of a TForm

Answer:

Create a message handler for the Windows Message WM_NCPAINT message. The following example paints a 1 pixel red border around the frame of the form.


type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  dc: hDc;
  Pen: hPen;
  OldPen: hPen;
  OldBrush: hBrush;
begin
  inherited;
  dc := GetWindowDC(Handle);
  msg.Result := 1;
  Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
  OldPen := SelectObject(dc, Pen);
  OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
  Rectangle(dc, 0, 0, Form1.Width, Form1.Height);
  SelectObject(dc, OldBrush);
  SelectObject(dc, OldPen);
  DeleteObject(Pen);
  ReleaseDC(Handle, Canvas.Handle);
end;

How to copy a *.bmp file from a floppy disc to a blob field

Problem/Question/Abstract:

How to copy a *.bmp file from a floppy disc to a blob field

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  tb: TBlobstream;
  tf: TFileStream;
begin
  table1.edit; {load from disk file and save in table}
  tf := TFileStream.create('splash.bmp', fmOpenRead);
  tb := TBlobstream.create(Table1PictureData, bmReadWrite);
  tb.CopyFrom(tf, 0);
  tf.free;
  tb.free;
  table1.post;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  tb: TBlobstream;
begin
  table1.active := true;
  if not (Table1.EOF) then
  begin
    Table1.first; {load from table and display}
    tb := TBlobstream.create(Table1PictureData, bmRead);
    Image1.Picture.Bitmap.LoadFromStream(tb);
    tb.free;
  end;
end;

Assertion Magic

Problem/Question/Abstract:

The ASSERT function shows you the line number and unit name from which it was launched. How can you get this functionality for different useages in your code

Answer:

Any information in this article has been checked on Delphi5 and Delphi 6 only (on Pentium II processor). It might not work on any other configuration !

First, we need to understand how the ASSERT fucntion works. As you've probably noticed, when an assertion occures, the error raised includes the line number and unit name. How does this happen? Where does the ASSERT function get that info from?

The answer is very simple. From Delphi's compiler. When Delphi compiles your code it addes a few lines in assembler code before the call to ASSERT. These assembler instructions contain the extra information the ASSERT function needs.
That is, the line number from which it was called, and the unit's name. But what if you want to have that info? How can you retreive the line number and unit name of a specific statment in your code? The answer is : you can't (at least as far as I know), at least not strait forwardly, but you can get it in some tricky way.

To solve this, we'll use Delphi's compiler. Since the compiler adds the extra information we're looking for before an ASSERT function, we'll put an ASSERT function in our code, and have the compiler add the needed information. Now we need to find a way to avoid the ASSERT function call (sinc we don't want a simple assertion error to happen). In order to do that, we'll add some assembler code to skip the ASSERT function. You might wonder why to put the ASSERT fucntion in the first place, if we're going to skip it in any case. The answer is, in order to read the extra information (line number and unit name) we have to let the compiler add it to our code, and that can be done only by adding the ASSERT function.

After skipping the ASSERT function, we'll read the information added by the compiler (using assembler) and put it in some global variables. Afterwards you can do what ever you wish with that info.

Here is the needed code :

var
  // Global variables to hold the result
  GLineNumber: Integer;
  GError, GUnitName: string;

asm

// Save EAX and EBX cause we're going to change them
    push eax
    push ebx
// The following 3 lines are in order to get the value of EIP
// "call" pushes EIP to the stack
    call @Temp
    @Temp:
// now we POP EIP into EBX
    pop ebx
// Add to EBX the value needed inorder to skip the ASSERT function
    add ebx, $1A
// Skip the ASSERT function by jumping to the code after it
    jmp ebx
  end;
ASSERT(False, 'Your Error Message Here');
  asm
// Make EBX point to the line number value that the compiler inserted
    sub ebx, $13
// Read that value into EAX
    mov eax, [ebx]
// Put the line number into GLineNumber
    mov GLineNumber, eax

// Same as above but for GUnitName
    add ebx, 5
    mov eax, [ebx]
    mov GUnitName, eax

// Same as above but for GError (the assertion error message)
    add ebx, 5
    mov eax, [ebx]
    mov GError, eax

// Restore the values of EBX and EAX
    pop ebx
    pop eax
end;

Let's look back again on what this code does.

Delphi's compiler adds some info before any ASSERT function it finds in the  code.
We add a call to ASSERT to make the compiler add the wanted information
We add assmbler code to skip the call to ASSERT
We add code (after the call to ASSERT) that reads to information that the compiler added.
We do what ever we wish with this information, for example - raise a better excpetion.

Note :

1) You might think this is to much code for such a simple task. Inorder to make this code shorter, you can but the assmbler code in a file, and use the {$I} include compiler directive. That way the code will look like this :

{$I PreAssert.INC}
ASSERT(False, 'YourMessage');
{$I PostAssert.INC}

2) You might want to override the assertion handling method in System.Pas instead of all of this, but then you won't be able to use regular ASSERT functions when they are needed.

3) This code is not meant to replace ASSERT. It just uses ASSERT inorder to retrieve the line number and unit name. This code is meant to get that information for a specific loacation in your code.

4) You must pass "False" as the first parameter of the ASSERT function you write. If you pass "True" then the compiler completly ignores the function, and if you pass a condition (eg. i = 5) the compiler will generate more code then expected, and the assembler instructions that I've provided won't work properly.

Fast data transfer to MS Excel

Problem/Question/Abstract:

How can I export data into MS Excel workbook?

Answer:

Anyone who worked with OLE automation, know that OLE is very slowly. Especially if you work using late binding (which have a lot of other advantages which early binding haven't)

A reason of bad performance is the next: every command (method or property) which you access (no matter in read or write mode) will be interpretated (a-la script). I mean that this command must be found in table of available methods/properties by string name and only if found, a physical memory address for execution will be calculated.

So if your code contain a lot of access to methods/properties, your code will be slow.

For example, you need transfer some data from Delphi application into xls-spreadsheet. You can solve a task in two different ways (now I describe only late binding for OLE automation and don't describe another methods):

to navigate thru own data and export every data in required cell
to prepare a variant array with copied data and apply this array with data into desired range of cells

I must say that second method will be faster than first because you'll call less commands from OLE object and main code will be executed without OLE automation.

Small sample: to export some StringGrid into xls-file.

var
  xls, wb, Range: OLEVariant;
  arrData: Variant;
begin
  {create variant array where we'll copy our data}
  arrData := VarArrayCreate([1, yourStringGrid.RowCount, 1,
    yourStringGrid.ColCount], varVariant);

  {fill array}
  for i := 1 to yourStringGrid.RowCount do
    for j := 1 to yourStringGrid.ColCount do
      arrData[i, j] := yourStringGrid.Cells[j - 1, i - 1];

  {initialize an instance of Excel}
  xls := CreateOLEObject('Excel.Application');

  {create workbook}
  wb := xls.Workbooks.Add;

  {retrieve a range where data must be placed}
  Range := wb.WorkSheets[1].Range[wb.WorkSheets[1].Cells[1, 1],
    wb.WorkSheets[1].Cells[yourStringGrid.RowCount, yourStringGrid.ColCount]];

  {copy data from allocated variant array}
  Range.Value := arrData;

  {show Excel with our data}
  xls.Visible := True;
end;

Of course, you must understand that such method is not good for large data arrays because to allocate in memory large array is not easy task. You must find some optimal size for data transfer (for example, to copy every 10 rows) and as result you'll receive an optimal code both for memory use and performance.

Anyway more faster way to transfer data is not use OLE at all:-) You can use my TSMExportToXLS component from SMExport suite (http://www.scalabium.com/sme) for this task. There is implemented a direct xls-file creation which doesn't require installed MS Excel at all..

Minimize an application when modal forms are present

Problem/Question/Abstract:

My application (non MDI) has many modal forms which are open most of the time. When the user wants to minimize the application and presses the minimize system button, he experiences only the top modal form gets minimized while the other forms (at least app's main form) are still at their current size. Moreover, the user now is confused because clicking on the main form does nothing but giving errors to him. I can not change the application's appearance or exchange the modal forms to some other solution. Is there a way I can keep my modal design and still enable users to minimize the application the way they are used to?

Answer:

Add a handler for WM_SYSCOMMAND to your modal forms. The handler should look like this:

private {form declaration}

procedure WMSyscommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;

procedure TForm2.WMSyscommand(var msg: TWmSysCommand);
begin
  case (msg.cmdtype and $FFF0) of
    SC_MINIMIZE:
      begin
        msg.result := 0;
        EnableWindow(Application.handle, true);
        Application.Minimize;
      end;
  else
    inherited;
  end;
end;

How to get a list of subdirectories and files in a folder

Problem/Question/Abstract:

I want to automatically search a directory and get a listing of all the subdirectories and files on that drive.

Answer:

Solve 1:

Here is one way:

function FindFiles(Directory: string; InclAttr, ExclAttr: Integer;
  const SubDirs: Boolean; const Files: TStrings): Integer;
var
  SearchRec: TSearchRec;
begin
  Directory := IncludeTrailingPathDelimiter(Directory);
  FillChar(SearchRec, SizeOf(SearchRec), 0);
  if FindFirst(Directory + '*.*', faAnyFile, SearchRec) = 0 then
  begin
    try
      repeat
        if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
          if ((SearchRec.Attr and InclAttr > 0) or ((SearchRec.Attr = 0) and (InclAttr
            <> faDirectory))) and
            (SearchRec.Attr and ExclAttr = 0) then
          begin
            Files.Add(Directory + SearchRec.Name);
            if SubDirs then
              if SearchRec.Attr and faDirectory <> 0 then
                FindFiles(Directory + SearchRec.Name, InclAttr, ExclAttr, SubDirs,
                  Files);
          end;
      until
        FindNext(SearchRec) <> 0;
    finally
      FindClose(SearchRec);
    end;
  end;
  Result := Files.Count;
end;

Example of usage:

procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStringList;
begin
  Memo1.Clear;
  sl := TStringList.Create;
  try
    FindFiles('c:\', faAnyFile, 0, True, sl);
    Memo1.Lines.Add('Number of directories/files: ' + IntToStr(sl.Count));
    Memo1.Lines.AddStrings(sl);
  finally
    sl.Free;
  end;
end;


Solve 2:

procedure GetFiles(APath: string; AExt: string; AList: TStrings; ARecurse: boolean);
var
  theExt: string;
  searchRec: SysUtils.TSearchRec;
begin
  if APath[Length(APath)] <> '\' then
    APath := APath + '\';
  AList.AddObject(APath, Pointer(-1));
  if FindFirst(APath + '*.*', faAnyFile, searchRec) = 0 then
  try
    repeat
      with searchRec do
      begin
        if (Name <> '.') and (Name <> '..') then
          if (Attr and faDirectory <= 0) then
          begin
            theExt := '*' + UpperCase(ExtractFileExt(searchRec.Name));
            if (AExt = '*.*') or (theExt = UpperCase(AExt)) then
              AList.AddObject(searchRec.Name, Pointer(0))
          end
          else
          begin
            if ARecurse then
            begin
              GetFiles(APath + Name + '\', AExt, AList, ARecurse);
            end;
          end;
      end;
      Application.ProcessMessages;
    until
      FindNext(searchRec) <> 0;
  finally
    SysUtils.FindClose(searchRec);
  end;
end;

Current date/time in InterBase

Problem/Question/Abstract:

How can I determine the current date/time in InterBase? (Version 5.0)

Answer:

InterBase supports four DATE literals. They are: 'today', 'yesterday', 'tomorrow' and 'now'
Use it with a cast as shown in the example below.

insert into mytable values(cast('now' as DATE), 'Test')

Respond to Windows messages

Problem/Question/Abstract:

Respond to Windows messages

Answer:

Using WM_WININICHANGED as an example:

Declaring a method in a TForm will allow you to handle WM_WININICHANGED messages:


procedure WMWinIniChange(var message: TMessage);
  message WM_WININICHANGE;

procedure TForm1.WMWinIniChange(var message: TMessage);
begin
  inherited;
  {.. react to someone mucking with control panel ..}
end;


The call to "inherited" is important. Note also that message handlers are special when calling their inherited since you don't refer to the name of the inherited.
This is because the inherited is referring to the inherited message handler for this message number, which might not have a visible name or or even the same name as you have given it, or in some cases, might not even exist (in which case you are really calling DefaultHandler).

Send an email from Delphi

Problem/Question/Abstract:

Send an email from Delphi

Answer:

It can be so easy to have your application pop up an email window.. assuming that a mail reader is installed (see below):

uses
  ShellAPI;

ShellExecute(0, 'open', 'mailto: peter@preview.org?subject=my subject',
  nil, nil, SW_SHOWNORMAL);

Netscape installation:
in the registry add this entry (use the correct path to Netscape.exe):

[HKEY_CLASSES_ROOT\mailto\shell\open\command]
@="\"C:\\Program Files\\Netscape\\Program\\Netscape.exe\" %1"

How to retrieve rich text from a resource file and save it to disk

Problem/Question/Abstract:

How to retrieve rich text from a resource file and save it to disk

Answer:

These are the basic steps:

Create a resource file
Include it in your project
Load the file from the resource file into a TResourceStream
Create a TFileStream with the filename you want to write to
Use CopyFrom to get the data from the TResourceStream to the TFileStream
Free both the streams

The file is magically written to disk, without any need to call a write procedure or anything like that. It takes a file called 'test.rtf' from the resource file TEST.RES and saves it out to disk as 'test2.rtf' in the application folder:

{$R TEST.RES}

procedure TfrmMain.Button1Click(Sender: TObject);
var
  ResStream: TResourceStream
  MyFileStream: TFileStream;
begin
  try
    MyFileStream := TFileStream.Create(ExtractFilePath(Application.ExeName) +
      ' test2.rtf ', fmCreate or fmShareExclusive);
    ResStream := TResourceStream.CreateFromID(HInstance, 1, RT_RCDATA);
    MyFileStream.CopyFrom(ResStream, 0);
  finally
    MyFileStream.Free;
    ResStream.Free;
  end;
end;

Read the content of Internet Explorer's "History" folder

Problem/Question/Abstract:

How can I delete the contents of the IE5 History folder? I know that it is a Special Folder, so do you need to run this process as the system? If so how?

Answer:

This will get you the history folder and then maybe you can use the DeleteFile function to delete all the files in the directory.

uses
  ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
const
  CSIDL_HISTORY = $0022; {no need to define if using Delphi 5}
var
  pidl: PItemIDList;
  Path: array[0..MAX_PATH - 1] of char;
begin
  {get location of history folder}
  if SHGetSpecialFolderLocation(Self.Handle, CSIDL_HISTORY, pidl) = NOERROR then
  begin
    SHGetPathFromIDList(pidl, Path);
    ShowMessage(Path);
  end;
end;

How to create only one instance of a MDI child form

Problem/Question/Abstract:

I want the form only to appear once on the user's desktop regardless of whether it has focus or not.

Answer:

procedure TfmMain.fmAboutClick(Sender: TObject);
begin
  if not (ActiveMDIChild is TfmAboutBox) then
    TfmAboutBox.Create(Application);
end;

procedure TfmMain.fmAboutClick(Sender: TObject);
var
  myAbout: TfmAboutBox;
  i: integer;
begin
  for i := 0 to Screen.FormCount - 1 do
    if (Screen.Forms[i] is TfmAboutBox) then
      myAbout := Screen.Forms[i] as TfmAboutBox; {Form Exists}
  if myAbout = nil then {didn't find it so create it...}
    myAbout = TfmAboutBox.Create(Application);
  myAbout.Show;
end;

How to control the positioning of MDI child forms

Problem/Question/Abstract:

I have written an inventory app in Delphi 4 using MDI forms. Everything seems to work great. The only thing is, that when I open one child form, then close that same child form and reopen it, the form descends a quarter of an inch. As I open other child forms, they keep descending the same quarter inch (or so). After about four open windows, the 5th opens back at the top of the parent form. Is there any way to have child windows open at the top of my parent window (especially when all other child forms have been closed).

Answer:

Try overriding CreateParams():


procedure CreateParams(var Params: TCreateParams); override;

  procedure TNotebook.CreateParams(var Params: TCreateParams);
  begin
    inherited CreateParams(Params); {call the inherited first}
    with Params do
    begin
      X := YourXPos;
      Y := YourYPos;
    end;
  end;

How to do a SELECT from different tables

Problem/Question/Abstract:

I am trying to select from 2 or more tables and I am unsuccessful. How would I go about this? I am using Delphi's Query component and I want to display columns from each table.

Answer:

First, the columns from each table must be included in the SELECT clause of the statement. Any columns not included will not be returned. However, if the columns list of a SELECT clause is an asterisk, all columns are returned.

Second, all tables in the join query must be listed in the FROM clause. How they are listed depends on the type of join used: inner, outer, full, or equi-join.

Third, a condition must be supplied by which any given row from one table is associated with some row from the other. Unless you supply this condition, you get what is known as a Cartesian join where every row from one table is joined with every row of the other. So if each table has 100 records, the result set will have 10,000 records (100*100). How the condition is provided varies with the type of join used. For equi-joins, the condition is in the WHERE clause. For all other type joins, the condition is in an ON section of the FROM clause.

Here is an example of an equi-join using the two sample Paradox tables Customer and Orders. From the Customer table, only the CustNo and Company columns are returned by the query. From the orders table, the OrderNo and AmountPaid columns are returned. These two tables have the CustNo column in common and so this is used for the join. (Join columns need not have the same name, only the same values between the two tables. In this case their having the same name is coincidental.):

SELECT C.CustNo, C.Company, O.OrderNo, O.AmountPaid
FROM "Customer.db" C, "Orders.db" O
WHERE (C.CustNo = O.CustNo)

Determine whether the computer supports hibernation, the sleep states

Problem/Question/Abstract:

How to determine whether the computer supports hibernation, the sleep states

Answer:

Check if hibernation is allowed

function HibernateAllowed: Boolean;
type
  TIsPwrHibernateAllowed = function: Boolean;
  stdcall;
var
  hPowrprof: HMODULE;
  IsPwrHibernateAllowed: TIsPwrHibernateAllowed;
begin
  Result := False;
  if IsNT4Or95 then
    Exit;
  hPowrprof := LoadLibrary('powrprof.dll');
  if hPowrprof <> 0 then
  begin
    try
      @IsPwrHibernateAllowed := GetProcAddress(hPowrprof, 'IsPwrHibernateAllowed');
      if @IsPwrHibernateAllowed <> nil then
      begin
        Result := IsPwrHibernateAllowed;
      end;
    finally
      FreeLibrary(hPowrprof);
    end;
  end;
end;

Check if suspend is allowed

function SuspendAllowed: Boolean;
type
  TIsPwrSuspendAllowed = function: Boolean;
  stdcall;
var
  hPowrprof: HMODULE;
  IsPwrSuspendAllowed: TIsPwrSuspendAllowed;
begin
  Result := False;
  hPowrprof := LoadLibrary('powrprof.dll');
  if hPowrprof <> 0 then
  begin
    try
      @IsPwrSuspendAllowed := GetProcAddress(hPowrprof, 'IsPwrSuspendAllowed');
      if @IsPwrSuspendAllowed <> nil then
      begin
        Result := IsPwrSuspendAllowed;
      end;
    finally
      FreeLibrary(hPowrprof);
    end;
  end;
end;

Change an ISAPI dll project to a CGI project, or vice-versa

Problem/Question/Abstract:

How do I change an ISAPI dll project to a CGI project, or vice-versa?  

Answer:

The easiest way to do this is with conditional build and defining the target in the source. By simply commenting the {$define dll} line, you can build an EXE instead of a DLL.

Create a new Web Server Application by choosing "File->New, Web Server Application", and selecting a "ISAPI/NSAPI Dynamic Link Library." After the project has been created, save it, and click "Project->View Source." Copy and paste the sample code from below into the project source.

// Comment or uncomment the line below to change from an ISAPI dll
// to a CGI app or vice-versa
//{$define dll}

{$IFNDEF dll}program Project;
{$APPTYPE CONSOLE}{$ELSE}library Project;
{$ENDIF}

uses WebBroker, {$IFDEF dll}ISAPIApp, {$ELSE}CGIApp, {$ENDIF}unit in 'Unit .pas'
{WebModule : TWebModule};

{$R *.RES}

{$IFDEF dll}exports GetExtensionVersion, HttpExtensionProc, TerminateExtension;
{$ENDIF}

begin
  Application.Initialize;
  Application.CreateForm(TWebModule, WebModule);
  Application.Run;
end.

Clipboard access routines which use only API functions

Problem/Question/Abstract:

Clipboard access routines which use only API functions

Answer:

This unit provides clipboard access routines that do not rely on the VCL Clipbrd unit. That unit drags in Dialogs and Forms and a major part of the VCL as a consequence, not appropriate for simple console or non-form programs. This unit uses only API routines, the only VCL units used are Classes (for exceptions and streams) and SysUtils.

{Clipboard access routines using only API functions
Author: Dr. Peter Below
Version 1.0 created 5 Juli 2000
Current revision 1.0
Last modified: 5 Juli 2000}

unit APIClipboard;

interface

uses
  Windows, Classes;

procedure StringToClipboard(const S: string);
function ClipboardAsString: string;
procedure CopyDataToClipboard(fmt: DWORD; const data; datasize: Integer;
  emptyClipboardFirst: Boolean = true);
procedure CopyDataFromClipboard(fmt: DWORD; S: TStream);
function ClipboardHasFormat(fmt: DWORD): Boolean;

implementation

uses
  Sysutils;

type
  {This is an internal exception class used by the unit=APIClipboard }
  EclipboardError = class(Exception)
  public
    constructor Create(const msg: string);
  end;

resourcestring
  eSystemOutOfMemory = 'could not allocate memory for clipboard data.';
  eLockfailed = 'could not lock global memory handle.';
  eSetDataFailed = 'could not copy data block to clipboard.';
  eCannotOpenClipboard = 'could not open the clipboard.';
  eErrorTemplate = 'APIClipboard: %s'#13#10 + 'System error code: %d'#13#10
    + 'System error message: %s';

  {EClipboardError.Create - Creates a new EclipboardError object

  Param msg is the string to embed into the error message
  Precondition: none
  Postcondition: none

  Description:
  Composes an error message that contains the passed message and the API error code
  and matching error message. The CreateFmt constructor inherited from the basic Exception
  class is used to do the work.

  Created 5.7.2000 by P. Below}

constructor EClipboardError.Create(const msg: string);
begin
  CreateFmt(eErrorTemplate, [msg, GetLastError, SysErrorMessage(GetLastError)]);
end;

{DataToClipboard - Copies a block of memory to the clipboard in a given format

Param fmt is the clipboard format to use
Param data is an untyped const parameter that addresses the data to copy
Param datasize is the size of the data, in bytes

Precondition:
The clipboard is already open. If not an EClipboardError will result. This precondition cannot be asserted, unfortunately.

Postcondition:
Any previously exisiting data of this format will have been replaced by the new data, unless datasize was 0 or we run into an exception. In this case the clipboard will be unchanged.

Description:
Uses API methods to allocate and lock a global memory block of approproate size,
copies the data to it and submits the block to the clipboard. Any error on the way will raise an EClipboardError exception.

Created 5.7.2000 by P. Below}

procedure DataToClipboard(fmt: DWORD; const data; datasize: Integer);
var
  hMem: THandle;
  pMem: Pointer;
begin
  if datasize <= 0 then
    Exit;
  hMem := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, datasize);
  if hmem = 0 then
    raise EclipboardError.Create(eSystemOutOfMemory);
  pMem := GlobalLock(hMem);
  if pMem = nil then
  begin
    GlobalFree(hMem);
    raise EclipboardError.Create(eLockFailed);
  end;
  Move(data, pMem^, datasize);
  GlobalUnlock(hMem);
  if SetClipboardData(fmt, hMem) = 0 then
    raise EClipboarderror(eSetDataFailed);
  {Note: API docs are unclear as to whether the memory block has to be freed in case of
  failure. Since failure is unlikely here lets blithly ignore this issue for now.}
end;

{DataFromClipboard - Copies data from the clipboard into a stream

Param fmt is the clipboard format to look for
Param S is the stream to copy to
precondition:  S <> nil
postcondition: If data was copied the streams position will have moved

Description:
Tries to get a memory block for the requested clipboard format. Nothing further is done if this
fails (because the format is not available or the clipboard is not open, we treat neither as error
here), otherwise the memory handle is locked and the data copied into the stream. Note that
we cannot determine the actual size of the data originally copied to the clipboard, only the
allocated size of the memory block! Since GlobalAlloc works with a granularity of 32 bytes the
block may be larger than required for the data and thus the stream may contain some spurious
bytes at the end. There is no guarantee that these bytes will be 0. If the memory handle
obtained from the clipboard cannot be locked we raise an (see class=EClipboardError) exception.

Created 5.7.2000 by P. Below}

procedure DataFromClipboard(fmt: DWORD; S: TStream);
var
  hMem: THandle;
  pMem: Pointer;
  datasize: DWORD;
begin
  Assert(Assigned(S));
  hMem := GetClipboardData(fmt);
  if hMem <> 0 then
  begin
    datasize := GlobalSize(hMem);
    if datasize > 0 then
    begin
      pMem := GlobalLock(hMem);
      if pMem = nil then
        raise EclipboardError.Create(eLockFailed);
      try
        S.WriteBuffer(pMem^, datasize);
      finally
        GlobalUnlock(hMem);
      end;
    end;
  end;
end;

{CopyDataToClipboard - Copies a block of memory to the clipboard in a given format

Param fmt is the clipboard format to use
Param data is an untyped const parameter that addresses the data to copy
Param datasize is the size of the data, in bytes
Param emptyClipboardFirst determines if the clipboard should be emptied, true by default

Precondition:
The clipboard must not be open already

Postcondition:
If emptyClipboardFirst is true all prior data will be cleared from the clipboard, even if
datasize is <= 0. The clipboard is closed again.

Description:
Tries to open the clipboard, empties it if required and then tries to copy the passed data to
the clipboard. This operation is a NOP if datasize <= 0. If the clipboard cannot be opened a (see
class=EClipboardError) is raised.

Created 5.7.2000 by P. Below}

procedure CopyDataToClipboard(fmt: DWORD; const data; datasize: Integer;
  emptyClipboardFirst: Boolean = true);
begin
  if OpenClipboard(0) then
  try
    if emptyClipboardFirst then
      EmptyClipboard;
    DataToClipboard(fmt, data, datasize);
  finally
    CloseClipboard;
  end
  else
    raise EclipboardError.Create(eCannotOpenClipboard);
end;

{StringToClipboard - Copies a string to clipboard in CF_TEXT clipboard format

Param S is the string to copy, it may be empty.

Precondition:
The clipboard must not be open already.

Postcondition:
Any prior clipboard content will be cleared, but only if S was not empty. The clipboard is closed again.

Description:
Hands the brunt of the work off to (See routine=CopyDataToClipboard), but only if S was
not empty. Otherwise nothing is done at all.

Created 5.7.2000 by P. Below}

procedure StringToClipboard(const S: string);
begin
  if Length(S) > 0 then
    CopyDataToClipboard(CF_TEXT, S[1], Length(S) + 1);
end;

{CopyDataFromClipboard - Copies data from the clipboard into a stream

Param fmt is the clipboard format to look for
Param S is the stream to copy to

Precondition:
S <> nil
The clipboard must not be open already.

Postcondition:
If data was copied the streams position will have moved. The clipboard is closed again.

Description:
Tries to open the clipboard, and then tries to copy the data to the passed stream. This
operation is a NOP if the clipboard does not contain data in the requested format. If the
clipboard cannot be opened a (see class=EClipboardError) is raised.

Created 5.7.2000 by P. Below}

procedure CopyDataFromClipboard(fmt: DWORD; S: TStream);
begin
  Assert(Assigned(S));
  if OpenClipboard(0) then
  try
    DataFromClipboard(fmt, S);
  finally
    CloseClipboard;
  end
  else
    raise EclipboardError.Create(eCannotOpenClipboard);
end;

{ClipboardAsString - Returns any text contained on the clipboard. Returns the clipboards
content if it contained something in CF_TEXT format, or an empty string.

Precondition: The clipboard must not be already open
Postcondition: The clipboard is closed.

Description:
If the clipboard contains data in CF_TEXT format it is copied to a temp memory stream,
zero-terminated for good measure and copied into the result string.

Created 5.7.2000 by P. Below}

function ClipboardAsString: string;
const
  nullchar: Char = #0;
var
  ms: TMemoryStream;
begin
  if not IsClipboardFormatAvailable(CF_TEXT) then
    Result := EmptyStr
  else
  begin
    ms := TMemoryStream.Create;
    try
      CopyDataFromClipboard(CF_TEXT, ms);
      ms.Seek(0, soFromEnd);
      ms.WriteBuffer(nullChar, Sizeof(nullchar));
      Result := Pchar(ms.Memory);
    finally
      ms.Free;
    end;
  end;
end;

{ClipboardHasFormat - Checks if the clipboard contains data in the specified format

Param fmt is the format to check for. Returns true if the clipboard contains data in this format, false otherwise

Precondition:  none
Postcondition: none

Description:
This is a simple wrapper around an API function.

Created 5.7.2000 by P. Below}

function ClipboardHasFormat(fmt: DWORD): Boolean;
begin
  Result := IsClipboardFormatAvailable(fmt);
end;

end.

TCheckBox inside a TRichEdit

Problem/Question/Abstract:

With my colleagues, we tried to implement a checkbox object into Rich Edit.
Is that possible anyway?

Answer:

This seems not possible from within the IDE/ Object Inspector. However, if you create the checkbox instance dynamically (at run-time), then it works as expected.
For the following example, create a new form, drop a TRichEdit on it and create the checkbox in the FormCreate() event.

The button event handler code moves the RichEdit control at run-time around to demonstrate that the checkbox really is its child.

unit fMain;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  RichEdit1.Left := 100 - RichEdit1.Left;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  cb: TCheckBox;
begin
  RichEdit1.Left := 20;

  cb := TCheckBox.Create(RichEdit1);
  // do not forget to set the
  cb.Parent := RichEdit1;
  cb.Left := 30;
  cb.Top := 30;
  cb.Caption := 'my checkbox';
end;

end.

How to split up a TPopupMenu into columns at runtime

Problem/Question/Abstract:

I have a PopupMenu, which contains a lot of menu items. Sometimes the user can't see all menus on the screen. The same problem occurs with MainMenu. How I can split PopupMenu at runtime that it will be all visible on the screen?

Answer:

TMenuItem has a Break property which you can use to split a menu up into columns. The following procedure lets you specify the number of items you want in each column:


procedure FormatMenu(item: TMenuItem; maxrows: integer);
var
  ix: integer;
  item2: TMenuItem;
begin
  for ix := 1 to item.Count - 1 do {ignore first}
  begin
    item2 := item.Items[ix];
    if ix mod maxrows = 0 then
      item2.Break := mbBreak
    else
      item2.Break := mbNone;
  end;
end;


You call it like:


FormatMenu(PopupMenu.Items, 4);


If instead of an absolute number, you want a specific number of columns, say three:


count := PopupMenu.Items.Count div 3;
if PopupMenu.Items.Count mod 3 > 0 then
  inc(count);
FormatMenu(PopupMenu.Items, count);

Save and load TListView items to / from a file

Problem/Question/Abstract:

I would like to know how to save TListView items and subitems into a file and reload them into the listview on a button click or the next time the program starts.

Answer:

Solve 1:

The answer depends on what information you need to save and restore: only the strings or also image indices, if the latter, which indices? If it's only the strings one could do it this way:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListView1: TListView;
    SaveButton: TButton;
    ClearButton: TButton;
    LoadButton: TButton;
    procedure ClearButtonClick(Sender: TObject);
    procedure SaveButtonClick(Sender: TObject);
    procedure LoadButtonClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{
Function IScan:
Parameters:
ch: Character to scan for
S : String to scan
fromPos: first character to scan
Returns: position of next occurence of character ch, or 0, if none found
Description: Search for next occurence of a character in a string
Error Conditions: none
Created: 11/27/96 by P. Below
}

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

{
Procedure SplitString:
Parameters:
S: String to split
separator: character to use as separator between substrings
substrings: list to take the substrings
Description: Isolates the individual substrings and copies them into the passed stringlist. Note that we only add to the list, we do not clear it first! If two separators follow each other directly an empty string will be added to the list.
Error Conditions: will do nothing if the stringlist is not assigned
Created: 08.07.97 by P. Below
}

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

resourcestring

  eInvalidViewstyle = '%s: the listview %s is not in vsReport mode.';

  {
  Procedure SaveListviewStrings:
  Parameters :
  listview : listview to save, must be in vsreport mode, <> nil
  filename : full pathname of file to create
  Description:
  Iterates over the items of the passed listview and saves the item and
        subitem strings to file. The created file is a plain text file, each item
        occupies one line, subitems are separated by tab characters.
  Error Conditions:
  An exception will be raised if the listview is not in vsreport mode or if the
        file cannot be written to.
  Created: 2.4.2000 by P. Below
  }

procedure SaveListviewStrings(listview: TLIstview; const filename: string);
var
  sl: TStringlist;
  S: string;
  i, k: Integer;
  item: TLIstItem;
begin
  Assert(Assigned(listview));
  if listview.ViewStyle <> vsReport then
    raise Exception.CreateFmt(eInvalidViewstyle, ['SaveListviewStrings',
      listview.name]);
  sl := TStringlist.Create;
  try
    for i := 0 to listview.items.count - 1 do
    begin
      item := listview.Items[i];
      S := item.Caption;
      for k := 0 to item.SubItems.Count - 1 do
        S := S + #9 + item.Subitems[k];
      sl.Add(S);
    end;
    sl.SaveToFile(filename);
  finally
    sl.free
  end;
end;

{
Procedure LoadListviewStrings:
Parameters :
listview : listview to load, must be in vsreport mode, <> nil
filename : full pathname of file to read
Description:
Reads the file into a stringlist and then dissects each line into another list
of strings. It expects the lists elements to be separated by tab characters. For
each line read a new listitem is added to the listview and its caption and subitems are set from the lines elements. Note that the listview is not cleared
first, so the new items will be added to whatever items the listview already contains.
Error Conditions:
An exception will be raised if the listview is not in vsreport mode or if the file cannot be loaded.
Created: 2.4.2000 by P. Below
}

procedure LoadListviewStrings(listview: TLIstview; const filename: string);
var
  sl, lineelements: TStringlist;
  i: Integer;
  item: TLIstItem;
begin
  Assert(Assigned(listview));
  if listview.ViewStyle <> vsReport then
    raise Exception.CreateFmt(eInvalidViewstyle, ['LoadListviewStrings',
      listview.name]);
  sl := TStringlist.Create;
  try
    sl.LoadFromFile(filename);
    lineelements := Tstringlist.Create;
    try
      for i := 0 to sl.count - 1 do
      begin
        lineelements.Clear;
        SplitString(sl[i], #9, lineelements);
        if lineelements.Count > 0 then
        begin
          item := listview.Items.Add;
          item.Caption := lineelements[0];
          lineelements.Delete(0);
          item.SubItems.Assign(lineelements);
        end;
      end;
    finally
      lineelements.free;
    end;
  finally
    sl.free
  end;
end;

const
  testfilename = 'c:\temp\testfile.txt';

procedure TForm1.ClearButtonClick(Sender: TObject);
begin
  listview1.items.clear;
end;

procedure TForm1.SaveButtonClick(Sender: TObject);
begin
  SaveListviewStrings(listview1, testfilename);
end;

procedure TForm1.LoadButtonClick(Sender: TObject);
begin
  LoadListviewStrings(listview1, testfilename);
end;

end.


Solve 2:

Subclass TListView and add these to your new component:

unit MyListView;

interface

uses
  SysUtils, Classes, ComCtrls, Forms, Windows, Menus, Controls;

type

  TCheckBoxString = class(TComponent)
  private
    FTheString: string;
  protected
  public
  published
    property CheckBoxString: string read FTheString write FTheString;
  end;

  TMyListView = class(TListView)
  private
  public
    procedure SaveToFile(FileName: string);
    procedure LoadFromFile(FileName: string);
  published
  end;

procedure Register;

implementation

procedure TMyListView.SaveToFile(FileName: string);
var
  FStream: TMemoryStream;
  i: Integer;
  FStrings: TCheckBoxString;
begin
  FStream := TMemoryStream.Create;
  FStrings := TCheckBoxString.Create(nil);
  try
    FStream.WriteComponent(Self);
    if Self.Checkboxes then
    begin
      FStrings.CheckBoxString := '';
      for i := 0 to Self.Items.Count - 1 do
      begin
        if Self.Items[i].Checked then
          FStrings.CheckBoxString := FStrings.CheckBoxString + 'T'
        else
          FStrings.CheckBoxString := FStrings.CheckBoxString + 'F';
      end;
      FStream.WriteComponent(FStrings);
    end;
    FStream.SaveToFile(FileName);
  finally
    FStream.Free;
    FStrings.Free;
  end;
end;

procedure TMyListView.LoadFromFile(FileName: string);
var
  FStream: TFileStream;
  i: Integer;
  FStrings: TCheckBoxString;
begin
  FStream := TFileStream.Create(FileName, fmOpenRead);
  FStrings := TCheckBoxString.Create(nil);
  try
    Self.Columns.BeginUpdate;
    Self.Items.BeginUpdate;
    Self.Items.Clear;
    Self := FStream.ReadComponent(Self) as TMyListView;
    if Self.Checkboxes then
    begin
      FStrings := FStream.ReadComponent(FStrings) as TCheckBoxString;
      for i := 0 to Self.Items.Count - 1 do
      begin
        if (i + 1) <= Length(FStrings.CheckBoxString) then
          Self.Items[i].Checked := (FStrings.CheckBoxString[i + 1] = 'T');
      end;
    end;
  finally
    FStream.Free;
    FStrings.Free;
    Self.Columns.EndUpdate;
    Self.Items.EndUpdate;
  end;
end;

Control Panel Applets

Problem/Question/Abstract:

How to develop control panel applets

Answer:

Integrating Configuration Programs with Windows

Control Panel applets are the small programs that are visible in, and run from, Windows Control Panel. They are typically used to configure hardware, the operating system, utility programs, and application software. This article shows you how to create and install your own Control Panel applet.

Why create your own custom Control Panel applet? Many programs you develop require configuration. You probably store the configuration parameters in an .INI file, the registry, or a database. Some programmers add code to their main programs to allow users to display, change, and save configuration parameters, perhaps making it accessible through an Options menu choice.

However, there are many reasons why you should consider placing this code in a separate Delphi project. Placing the configuration code in a separate Delphi project not only makes it more modular, and thus easier to debug, it also makes it more amenable to parallel development within a team of programmers. The separate Delphi project will also exhibit high cohesion and low coupling.

By placing the configuration code in a separate Delphi project, you can more easily prevent end-user access to the code. You may want just an administrator to be able to change the configuration parameters. If this is the case, you could install the compiled project on just the administrator's machine or, if it is on a file server, you could modify the file's execute permission so that only administrators can execute it.

Placing the configuration code in a separate Delphi project allows you to convert it to a Control Panel applet, making it appear more professional and integrated with Windows. Users and administrators are used to looking in Control Panel when they want to configure something. Why should it be any different when it comes to your program?

A Control Panel applet is a special .DLL that resides in the Windows system directory. In this article, we'll discuss implementing a simple dialog box run from an .EXE, converting the dialog box to a .DLL, and converting the .DLL into a special .DLL with the file extension .CPL. (All three projects are available for download; see end of article for details.)

Simple Dialog Box Executable

The first Delphi project builds an executable and uses only one unit/form: AlMnDlg.pas/AlMnDlg.dfm (see Figure 1). The project uses an icon that is different from the default Delphi torch-and-flame icon. The form's name is MainDlg, its BorderStyle property is set to bsDialog, and it contains two buttons. Each button's ModalResult property is set to something other than mrNone. When we're done, this dialog box will be what appears when you activate the applet from the Control Panel.


Figure 1: The Control Panel applet's main dialog box.

Dynamic Link Library

The second Delphi project builds a .DLL and uses the same form as the first project. It also adds a second unit, AlMain.pas, that implements the Execute procedure. The unit's interface section contains the Execute procedure's header so it can be used outside the unit. The procedure uses the stdcall calling convention, because it will be exported from the .DLL. Execute simply creates the dialog box, shows it modally, and destroys it. Its definition is shown here:

procedure Execute; stdcall;
begin
  AlMnDlg.MainDlg := AlMnDlg.TMainDlg.Create(nil);
  try
    AlMnDlg.MainDlg.ShowModal;
  finally
    AlMnDlg.MainDlg.Free;
    AlMnDlg.MainDlg := nil;
  end;
end;

It was easy enough to test the first Delphi project's compiled executable, Applet.exe. All we had to do was run it. To test the second Delphi project's compiled executable, Applet.DLL, we'll have to build a program whose sole purpose is to exercise the .DLL. This is done in AlDriver.dpr. It contains a single form named MainDlg that resides in ADMain.pas/ADMain.dfm, and has a single Execute button (see Figure 2).


Figure 2: The driver executable's main dialog box.

The button's OnClick event handler calls the Execute procedure exported by Applet.DLL:

procedure TMainDlg.ExecuteButtonClick(
  Sender: System.TObject);
begin
  ADMain.Execute;
end;

For the Applet DLL's Execute procedure to be visible in the ADMain unit, it must be imported from the .DLL. Once it's imported, it appears to the rest of the code to actually exist in the unit at the location of the import statement. (This explains why the fully-qualified procedure name, ADMain.Execute, works.) The procedure is statically imported using the external directive:

procedure Execute; external 'Applet.DLL';

Because no path is specified, Windows uses an algorithm to search for the .DLL. One of the directories searched is the Windows system directory. Another is the directory from which the application loaded. In fact, that directory is searched first, and is the preferred directory to use. The search algorithm is documented in win32.hlp (on the Index tab, search on "LoadLibrary").

It's simple to go into AlDriver.dpr's Project | Options menu choice, change to the Directories/Conditionals page, and type the directory path to where Applet.DLL is located in the Output directory combo box. If you do so in your driver project, it will automatically be saved in the same directory as the .DLL whenever your driver executable is built.

To test Applet.DLL, place AlDriver.exe into Applet.DLL's directory if it's not already there. Run AlDriver.exe and click the Execute button. You should see the original dialog box on screen. Because it's shown modally, and both buttons have modal results set to something other than mrNone, clicking either one of them closes (and frees) the dialog box. When you're done testing the .DLL, close AlDriver.exe.

Congratulations! You now know how to place a form in a .DLL. Only a few more steps are required to convert the .DLL into a Control Panel applet.

Control Panel Applet

To test the second Delphi project, we had to build a driver program to load the .DLL, import a subroutine, and execute the subroutine. To test the final Delphi project (the one that builds the Control Panel applet), we won't have to build a driver program. Why? Windows itself will be the driver program. This controlling application is usually Control Panel itself, or the Control Panel folder in Windows Explorer. Like our driver program, the controlling application will have to load the applet, import a subroutine, and execute the subroutine.

To load the Control Panel applet, the controlling application must first find it. The simplest way to allow the controlling application to find the applet is to copy it to the Windows system directory. How does it distinguish between Control Panel applet .DLLs and regular .DLLs? Control Panel applet .DLLs have the extension .CPL - not .DLL. You can make your project automatically use the .CPL extension instead of the .DLL extension. To do so, select Project | Options. On the Application page, type cpl in the Target file extension edit box.

To import a subroutine from a .DLL, the controlling application must use the subroutine's name or index. Windows uses the name, and looks for a function named CPlApplet with the following signature:

LONG APIENTRY CPlApplet(
  HWND hwndCPl, // Handle to Control Panel window.
  UINT uMsg, // Message.
  LONG lParam1, // First message parameter.
  LONG lParam2 // Second message parameter.
  );

The code is shown in C because it's from the Microsoft Help file win32.hlp (refer to the "References" section at the end of this article for more information). The Object Pascal equivalent is:

function CPlApplet(hwndCPl: Windows.THandle;
  uMsg: Windows.DWORD; lParam1, lParam2: System.Longint):
  System.Longint; stdcall;

This function header is declared in cpl.pas. If you have the Professional or Client/Server versions of Delphi, you have access to the source for the cpl.pas unit. You don't need it to create Control Panel applets, but it's heavily commented, and therefore provides good documentation.

Unlike our Execute procedure, the CPlApplet function is called many times and performs multiple functions, depending on what parameter values are passed. The table in Figure 3 shows the possible values for the uMsg parameter. (The information found in this table comes mostly from win32.hlp.)

What
When
Why
CPL.CPL_INIT
Called immediately after the .CPL containing the applet is loaded.
The CPlApplet function should perform initialization procedures, e.g. memory allocation if necessary. If it can't complete the initialization, it should return zero, directing the controlling application to terminate communication, and release the .CPL. If it can complete the initialization, it should return any non-zero value.
CPL.CPL_GETCOUNT
Called after the CPL_INIT function call returns any non-zero value.
The CPlApplet function should return the number of dialog boxes it implements.
CPL.CPL_INQUIRE
Called after the CPL_GETCOUNT function call returns a count greater than, or equal to, 1. The CPlApplet function will be called once for each dialog box, indicating which dialog box with its 0-based index placed in lParam1.
The CPlApplet function should provide information about a specified dialog box. The lParam2 parameter points to a CPLINFO record. The CPlApplet function uses this record to tell the controlling application the applet's name, description, and icon.
CPL.CPL_DBLCLK
Called after the user has chosen the icon associated with a given dialog box.
The CPlApplet function should display the corresponding dialog box, and carry out any user-specified tasks.
CPL.CPL_STOP
Called once for each dialog box before the controlling application closes, indicating which dialog box with its 0-based index placed in lParam1.
The CPlApplet function should free any resources associated with the given dialog box.
CPL.CPL_EXIT
Called after the last CPL_STOP function call and immediately before the controlling application uses the FreeLibrary function to free the .CPL containing the applet.
The CPlApplet function should free any remaining resources, and prepare to close.

Figure 3: Possible values for the CPlApplet parameter, uMsg.

Each CPL_XXX constant is defined in the CPL unit. The example project's CPlApplet function uses these constants (see Figure 4).

function CPlApplet(hwndCPl: Windows.THandle;
  uMsg: Windows.DWORD; lParam1, lParam2: System.Longint):
  System.Longint; stdcall;
const
  NonZeroValue = 1;
begin
  case uMsg of
    CPL.CPL_INIT: Result := NonZeroValue;
    CPL.CPL_GETCOUNT: Result := 1;
    CPL.CPL_INQUIRE:
      case lParam1 of
        0:
          begin
            Result := NonZeroValue;
            CPL.PCPLInfo(lParam2)^.idIcon := AlConst.IIcon;
            CPL.PCPLInfo(lParam2)^.idName := AlConst.SName;
            CPL.PCPLInfo(lParam2)^.idInfo := AlConst.SInfo;
            Result := 0;
          end;
      else
      end;
    CPL.CPL_DBLCLK:
      begin
        Result := NonZeroValue;
        AlMnDlg.MainDlg := AlMnDlg.TMainDlg.Create(nil);
        try
          AlMnDlg.MainDlg.ShowModal;
        finally
          AlMnDlg.MainDlg.Free;
          AlMnDlg.MainDlg := nil;
        end;
        Result := 0;
      end;
    CPL.CPL_STOP: Result := 0;
    CPL.CPL_EXIT: Result := 0;
  end;
end;
Figure 4: An implementation of the applet's exported function CPlApplet.

As the description for CPL_GETCOUNT indicates, it's possible to implement multiple Control Panel applets (i.e. dialog boxes) per .CPL. The example project, however, implements only one.

After you tell Windows how many dialog boxes your .CPL implements, it calls the CPlApplet function again with uMsg equal to CPL_INQUIRE once for each dialog box. The lParam1 parameter tells you which dialog box the function call is for. It will be numbered from 0 to NumberOfDialogBoxes - 1. Because the example project only implements one applet, the CPlApplet function will only be called once so it doesn't handle the cases where lParam1 is other than 0.

The CPLINFO record is defined in win32.hlp as:

typedef struct tagCPLINFO { // cpli
int idIcon;
int idName;
int idInfo;
LONG lData;
} CPLINFO;
  
and in cpl.pas as:

PCPLInfo = ^TCPLInfo;
tagCPLINFO = packed record
  idIcon: System.Integer; // Icon resource id.
  idName: System.Integer; // Name string res. id.
  idInfo: System.Integer; // Info string res. id.
  lData: System.Longint; // User defined data.
end;
CPLINFO = tagCPLINFO;
TCPLInfo = tagCPLINFO;
  
The controlling application allocates memory for this record, and passes your CPlApplet function a pointer to it in the lParam2 parameter. All your function has to do is dereference the pointer, fill in its fields, and return zero. But what should the function fill the record with?

The controlling application needs three things from your applet in order to display it inside the Control Panel properly: an icon, a name, and a description. These three things must be resources linked into your executable with unique identifiers. The record is filled with the resource identifiers. How do you link resources into and use them from your executable? There are five things you must do:

find a suitable icon,
create a text resource file,
compile the text resource file into a binary resource file,
link the binary resource file into your executable, and
use the resources in your Object Pascal code.

The example project uses one of the icons that comes with Delphi, but renames it to Applet.ico. The text resource file, Applet.rc, is shown here:

#include "AlConst.pas"
  
STRINGTABLE
{
  SName, "Applet",
  SInfo, "Test applet"
}
  
IIcon ICON ..\Applet.ico

There are two kinds of resources in this resource file: a string resource (STRINGTABLE), and an icon (ICON) resource. Each string resource has a pair of values: its identifier and its value. The value is shown in double quotes. The identifier is a constant that represents an integer. The constants are defined in the unit AlConst.pas (see Figure 5), which is included within Applet.rc by using the #include directive.

unit AlConst;

interface

const
  SName = 1;
  SInfo = 2;
  IIcon = 3;

implementation

end.
Figure 5: The AlConst.pas file.

The icon resource also has a pair of values: its identifier and the file that contains the icon. The identifier comes from the AlConst unit, just like the string resource identifiers. The file name shown (..\Applet.ico) includes path information because Applet.ico isn't in the same directory as Applet.rc. Now, two of the five tasks required to link in and use resources are finished: finding a suitable icon, and creating a text resource file. What remains is to compile the text resource file into a binary resource file, link the binary resource file into the executable, and use the resources in Object Pascal code.

To compile the text resource file into a binary resource file, use brcc32.exe. This command-line utility comes with Delphi and can be found in the Delphi \Bin directory. Change to the directory that contains Applet.rc and use the following command:

brcc32.exe Applet.rc

This creates an output file in the same directory, and with the same name as the input file Applet.rc, but with the extension .RES. Applet.RES is the binary resource file. You can inspect the file by opening it with the Delphi Image Editor (from the Tools menu).

Linking the binary resource file into the executable is a simple matter of adding a compiler directive to Applet.dpr:

{$R ..\Applet.RES}
  
In the sample project, the Applet.RES file generated from Applet.rc is in the directory immediately above Applet.dpr, hence the ..\ path information in front of the file name. It's a good thing, too, because Delphi automatically generates another Applet.res file in the same directory as the .dpr. This explains the directive you always see in Delphi project files:

{$R *.RES}

The asterisk here means "the same file name as the .dpr," not "any file name."

Now that the binary resource file will be linked into your executable the next time it's recompiled, how do you go about using the resources in Object Pascal? All you have to do now is include the AlConst unit in the uses clause of the unit that needs access to the resource identifiers. In the example project, this is the AlMain unit.

The only other uMsg parameter values that need explanation are CPL_STOP and CPL_EXIT. Because the sample project allocates and deallocates needed memory from within the CPL_DLBCLK case statement block, the CPL_STOP and CPL_EXIT case statements don't have to do anything except indicate success by returning 0.

Conclusion

Windows' open architecture, and Delphi's combination of ease and power, allow you to locate configuration code in custom Control Panel applets. Using custom Control Panel applets makes your application look more professional, polished, and integrated with Windows.

References

The win32.hlp file is part of Microsoft's Windows software development kit. It comes with Delphi, and if you accepted the default locations when you installed Delphi, it can be located at either C:\Program Files\Common Files\Borland Shared\MSHelp if you have Delphi 4 or 5, or at C:\Program Files\Borland\Delphi 3\HELP if you have Delphi 3. Open the file, make sure the Contents tab is selected, and scroll down until you see Control Panel Applications.

The CPL unit found in cpl.pas is a port of cpl.h. It comes with Delphi, and if you accepted the default locations when you installed Delphi, it can be found at either C:\Program Files\Borland\Delphi5\Source\Rtl\Win\cpl.pas if you have Delphi 5 (substitute 4 for 5 if you're using Delphi 4), or at C:\Program Files\Borland\Delphi 3\Source\Rtl\Win\cpl.pas if you have Delphi 3. Another reference from Inprise can be found at http://www.borland.com/devsupport/delphi/faq/FAQ1043D.html, although it seems to be old code (Delphi 2), because it isn't aware of the CPL unit added in Delphi 3. A reference from Microsoft can be found at http: //support.microsoft.com/support/kb/articles/q149/6/48.asp.

Create a Program Group for an application

Problem/Question/Abstract:

Is there a Delphi function or API function with which I can create a program group for an application?

Answer:

Yes, MkDir or CreateDir. The program "groups" are in fact simple directories under the users profile directory.

uses
  ShlObj;

procedure FreePidl(pidl: PItemIDList);
var
  allocator: IMalloc;
begin
  if Succeeded(ShGetMalloc(allocator)) then
  begin
    allocator.Free(pidl);
{$IFDEF VER90}
    allocator.Release;
{$ENDIF}
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  pidl: PItemIDList;
  buf: array[0..MAX_PATH] of Char;
begin
  if Succeeded(ShGetSpecialFolderLocation(Handle, CSIDL_PROGRAMS, pidl)) then
  begin
    if ShGetPathfromIDList(pidl, buf) then
      ShowMessage(buf); {buf has startmenu\programs folder}
    FreePIDL(pidl);
  end;
end;

How to store form method pointers in a TList

Problem/Question/Abstract:

What is the correct way to store form method pointers on a TList then use the TList items[] to call the various procedures?

Answer:

This isn't as easy as it seems. Despite the name, method pointers aren't pointers, they're 8-byte records (type TMethod, check the Help). So, you have to New a TMethod on the heap for each method pointer you want to store to the list, and of course free the records before you clear or free the list:


type
  TmyMethod = procedure(s: string) of object;
  TpMyMethod = ^TmyMethod;
  TpMethPtr = ^Tmethod;

procedure addMethodPointer(lst: TList; mp: TmyMethod);
var
  p: TpMethPtr;
begin
  new(p);
  p^ := Tmethod(mp);
  lst.add(p);
end;

procedure clearPointers(lst: TList);
var
  j: integer;
begin
  for j := 0 to lst.count - 1 do
  begin
    dispose(TpMethPtr(lst[j]));
  end;
end;


The fancy casting in addMethodPointer is so you can change the parameter type for mp without changing anything else.

The call to a given pointer goes this way:


TpMyMethod(lst[1])^(myString);

Run queries in threads

Problem/Question/Abstract:

I have several programs that run large queries, and would like to move the query processing to one or more background threads. How can I implement this in my program?

Answer:

NOTE: It's tough to discuss this subject without providing some background information. Threaded programming is so new to many programmers, I'd be remiss in my duties as The Delphi Pro if I didn't cover the most fundamental subjects of threaded programming. If you already have a good idea of the fundamentals of creating and running threads with the TThread component, you can skip to the section that deals with running queries in threads. -- The Delphi Pro

Process and Thread Basics

Many programmers, especially those new to programming with multiple threads, believe threads are the sole domain of programming gurus. But it's all a matter of understanding some fundamental concepts about how threads work in Delphi and how you can apply threads in your code.

If what you're programming has to do with the User Interface, you don't want to use multiple threads because threads require resources. In fact, every time you create a thread, it gets the same size stack as the main thread of a program (we'll discuss this below). If you have a lot of threads, you'll take up a lot of resources. So the idea is to be judicious in your use of threads. It may be tempting to create a bunch of threads to handle a bunch of different tasks because creating threads, as you will see, is fairly easy. But you don't want to create threads just for the sake of creating threads. In addition to taking up resources, every executing thread creates another time slice on the CPU, forcing it to handle more tasks. The net result is that the computer will slow way down. But there are some instances in which running background threads makes a lot of sense:

It's ideal to create background threads when:

your program will execute a long process like a huge query or complex calculation that will take several seconds or minute to execute. In single-threaded programs in Win16 and Win32 alike, the interface becomes totally unresponsive if you execute a long process. Creating a separate thread of execution to run in the background frees up the user interface.
your program runs in a multi-processor system. Windows NT, for example, has the ability to work SMP systems. With multi-threaded programs, individual threads may be executed on different processors, which means you take full advantage of balancing processor load.
your program will need to execute a few processes at a time. One caveat: If you're running on a single CPU system and if the processes your program will be executing are pretty complex and will require lots of CPU cycles, it doesn't make sense to have several simultaneous threads running. However, I've found that with smaller operations that can execute in a few seconds, it's a pretty nice feature to have.

In Windows 95 and NT (I'll refer to both systems as Win32 throughout this article), every program loaded into memory is called a process. Many people new to threads (including myself) make the mistake of believing that the definition of a process is interchangeable with that of a thread. It's not.

Processes are their own entities. Though the name "processes" implies a form of activity, a process does nothing. It is merely a memory address placeholder for its threads and a space where executable code gets loaded.

A process' thread is what actually does the work in a program. When a process is created in Win32, it automatically has an execution thread associated with it. This is called the main thread of the program. Other threads can be instantiated within a process, but you won't see many programs using multiple threads of execution. A thread can only be associated with one process, but a process can have many threads. Therefore, there is a distinct one-way, one-to-many relationship between processes and threads.

The TThread Object

Traditionally, processes (executing programs) are created in Win32 using the WinAPI CreateProcess and threads are created using CreateThread. In fact, many advanced Delphi and Windows programmers I've spoken with say that using the WinAPI call is their method of preference. With Delphi 2.0, the Delphi team created a wrapper class called TThread that encapsulates the WinAPI thread calls. TThread provides developers with a programmatic interface for creating multiple threads of execution in their programs. It also makes the job of creating and maintaining threads easier than directly using WinAPI calls.

Does this come at a price? I don't know. I have several multithreaded applications using both straight WinAPI calls and the TThread object and haven't noticed any significant differences. But my test arena was not as wide as it should have been to accurately gauge performance differences.

Most of the VCL is not thread-safe -- it's very important to take this into consideration when creating multiple threads of execution. If you call a VCL object from within a thread, most likely you'll raise an exception, because many of the VCL objects were not written with any type of synchronization code to ensure data integrity when called at random times from anything but the main thread. Essentially, they can only receive messages from a single thread. If they get a message from another thread, they'll hiccup, and your program will probably crash. Fortunately, TThread has a very simple way of safely making calls into the VCL that we'll discuss in a bit.

Let's look at the TThread's structure.

Here's the declaration for the TThread object:

TThread = class
private
  FHandle: THandle;
  FThreadID: THandle;
  FTerminated: Boolean;
  FSuspended: Boolean;
  FMainThreadWaiting: Boolean;
  FFreeOnTerminate: Boolean;
  FFinished: Boolean;
  FReturnValue: Integer;
  FOnTerminate: TNotifyEvent;
  FMethod: TThreadMethod;
  FSynchronizeException: TObject;
  procedure CallOnTerminate;
  function GetPriority: TThreadPriority;
  procedure SetPriority(Value: TThreadPriority);
  procedure SetSuspended(Value: Boolean);
protected
  procedure DoTerminate; virtual;
  procedure Execute; virtual; abstract;
  procedure Synchronize(Method: TThreadMethod);
  property ReturnValue: Integer read FReturnValue write FReturnValue;
  property Terminated: Boolean read FTerminated;
public
  constructor Create(CreateSuspended: Boolean);
  destructor Destroy; override;
  procedure Resume;
  procedure Suspend;
  procedure Terminate;
  function WaitFor: Integer;
  property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  property Handle: THandle read FHandle;
  property Priority: TThreadPriority read GetPriority write SetPriority;
  property Suspended: Boolean read FSuspended write SetSuspended;
  property ThreadID: THandle read FThreadID;
  property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
end;

Its structure is quite simple -- and simple is good

In most components there are only a few procedures and properties you need to think about; this is not an exception with TThread. The only methods you'll need to worry about are Execute, Create, and Synchronize; and the only property that you'll usually need to access is FreeOnTerminate.

Key Methods and Properties of TThread

The key methods and property of TThread are listed below in Table 1.

Table 1 -- Key Attributes of TThread

Attribute: Create                        Parameters: CreateSuspended: Boolean
The Create method allocates memory, starts the thread and specifies the thread function in CreateThread as the Execute procedure. Here, as in any Create method, you can initialize vars and perform some preliminary operations. However, unlike a normal Create method, the thread is already executing by the time the method ends. Usually this isn't a problem because you'll just create the object and forget about it. But if you have to do any processing before the thread starts executing, set the CreateSuspended parameter to False. This allocates memory for the thread and sets it up, but the thread will not execute until you make a call to the Resume procedure. This is useful, especially if you need to set up values your thread will need over the course of its lifetime.

Attribute: Execute                        Parameters: None
Execute is your TThread's central execution method. It's fairly synonymous with a main processing or central control procedure or function you might use to execute all the procedures in a particular unit. The only difference is that with a TThread object, the first method that is called must be called Execute. This doesn't mean that you can't call another procedure which acts in that capacity from Execute. It's definitely more convenient to put your execution code here because that's Execute's purpose.

One important note: If you look in the object declaration of TThread, you'll see that it is declared as a virtual; abstract; method. This means it's not implemented in any way, shape or form; therefore, it's up to you to provide the code. And there's no inherited functionality, so you'll never make a call to inherited Execute; in your own implementation.

Attribute: Synchronize                        Parameters: Method:TThreadMethod
Synchronize is your key to safely accessing the VCL in your thread. When Synchronize executes, your thread becomes a part of the main thread of the program, and in the process, suspends the operation of the main thread. This means the VCL can't receive messages from other threads other than the one you're synchronizing to the main thread, which in turn makes it safe to execute any VCL calls.

Think of Synchronize as a middleman in a transaction. You have a buyer, which is the main thread of the program, and a seller of services, which is another thread of execution created within the same process. The seller would like to sell the buyer some goods -- in our case, do some operation on the VCL components running in the main thread -- but the buyer doesn't really know the seller, and is appalled at how the seller actually performs his service, so is afraid the seller's service may have a negative effect on him. So the seller enlists the help of an agent (the Synchronize procedure) to smooth things out, take the buyer out to lunch so the seller can do his thing.

The seller is a procedure that performs the action on behalf of the thread. It doesn't have to be a specific type, but it must be a method of the thread. Say I have a long process running in a background thread that at certain times must update the text in a TPanel on the main form to give feedback about the thread's current status to the user. If I wrote in my code Form1.Panel1.Caption := 'This is my update message', I'd raise an exception -- most likely an access violation error. But if I encapsulate the call in a procedure, then call Synchronize, the message will be sent and text will be updated. Synchronize acted as a middleman so my status message could be passed to the TPanel.

I've may have confused rather than enlightened you! Just remember this:

When you want to call VCL objects from another thread, create a wrapper procedure for the operations you want to carry out, then use Synchronize to synchronize your thread with the main thread so your call can be safely executed.

Synchronize is meant to be used really quickly. Execute it, then get out of it as soon as you can. While Synchronize is running, you essentially have only one thread working. The main thread is suspended.

Attribute: FreeOnTerminate                        Parameters: Set property to Boolean value
This is a really useful property. Typically, once your execute procedure finishes, the Terminated Boolean property is set to False. However, the thread still exists. It's not running, but it's taking up space, and it's up to you to free the thread. But by setting this property in the Create constructor to True, the thread is immediately freed -- and with it, all the resources it took up -- after it's finished executing.

A Real-life Example

Most people get more out of seeing code examples to implement a certain concept. Below are code excerpts from a program that I wrote that performs a bunch of queries in sequence. First we have the type declaration:

type
  TEpiInfoProc = class(TThread)
    {Base processing class for Episode Information processing}
  private
    FStatMsg: string;
    FSession: TSession;
    tblPrimary,
      tblHistory,
      tblSymmetry: string;
    FIter: Integer;
    property Iteration: Integer read FIter write FIter;
    procedure eiCreateEpiTemp1; //Performs initial joins
    procedure eiCreateEpiTemp2; //Creates new table of summarized info
    procedure eiGetClassifications(clState, //'AMI', 'Asthma', etc.
      clName, //'H1', 'H2', etc.
      priFld, //Join field from Primary
      hstFld: string; //Join field from History
      bMode: TBatchMode); //Batch Mode (will always be
    //batCopy 1st time);
    procedure eiCreateEpiInfoTable(clSrc, clDst, clName: string);
    procedure eiCreateHistory(HistIndicator: string);

    //Generic processing methods
    procedure EnableBtns;
    procedure GetTableNames;
    procedure UpdStatus;
    procedure IndexTbl(dbName, tblName, idxName, fldName: string; idxOpts:
      TIndexOptions);
  protected
    procedure Execute; override;
  public
    constructor Create;
  end;

The above is like anything you see in Delphi when you declare a descendant of a class. You declare your variables, properties, and methods just like anything else.

Here's the Create constructor for the thread:

constructor TEpiInfoProc.Create;
begin
  inherited Create(True);
  FSession := TSession.Create(Application);
  with FSession do
  begin
    SessionName := 'EpiInfoSession';
    NetFileDir := Session.NetFileDir;
    PrivateDir := 'D:\EpiPriv';
  end;
  FreeOnTerminate := True;
  Resume;
end;

Notice I'm creating a new TSession instance. When we discuss running queries in threads, I'll go into more depth about this. At this point the important thing to note is that I create the thread in a suspended state by calling the inherited Create and setting its CreateSuspended parameter to True. This allows me to perform the code immediately below the inherited Create before the thread code actually starts running. Now, on to the Execute procedure.

procedure TEpiInfoProc.Execute;
var
  N, M: Integer;
begin
  try
    Synchronize(EnableBtns);
      //Set enabled property of buttons to opposite of current state
    Synchronize(GetTableNames); //Get Names
    FStatMsg := 'Now performing initial summarizations';
    Synchronize(UpdStatus);
    ShowMessage('Did it!');
    Exit;
    eiCreateEpiTemp1;
    eiCreateEpiTemp;
    {Create H1 - H9 tables}
    for N := 0 to 8 do
      for M := 0 to 5 do
      begin
        FStatMsg := 'Now performing ' + arPri[M] + ' field extract for ' + arDis[N];
        Synchronize(UpdStatus);
        Iteration := M;
        //first iteration must be a batCopy, then batAppend thereafter
        if (M = 0) then
          eiGetClassifications(arDis[N], arCls[N], arPri[M], arHst[M], batCopy)
        else
          eiGetClassifications(arDis[N], arCls[N], arPri[M], arHst[M], batAppend);
      end;

    {Now do Outer Joins}
    for N := 0 to 8 do
    begin
      FStatMsg := 'Now creating ' + arDst[N];
      Synchronize(UpdStatus);
      eiCreateEpiInfoTable(arSrc[N], arDst[N], arCls[N]);
    end;

    IndexTbl('EPIINFO', 'EpiInfo', 'Primary', 'Episode', [ixPrimary]);

    for N := 0 to 8 do
      eiCreateHistory(arCls[N]);

    FStatMsg := 'Operation Complete!';
    Synchronize(UpdStatus);
    Synchronize(EnableBtns);
  except
    Terminate;
    Abort;
  end;
end;

Notice all my calls to Synchronize, especially the synchronized call to UpdStatus. Immediately preceding this call, I set a variable called FStatMsg to some text. UpdStatus uses this text to set the SimpleText of a TStatusBar on the main form of the program.

Why not just pass this as a string variable parameter to UpdStatus? Because synchronized methods cannot have parameters. If you need to pass parameters, you must either set them in variables or create a structure to hold values your synchronized method can then access and pass to your main form.

Also take note of the looping structures I've written. You might be tempted to run a loop within a synchronized method. Although your code will work, this defeats the purpose of multiple threads because of what we discussed above. Synchronization makes your thread part of the main thread during the time it is executing, meaning you have only one thread actually running. This reduces your program to a single thread of execution. And if you have a potentially long process like several sequential queries executed from within a loop like I have above, forget it! Your program will act just like a single-threaded application until you're out the loop.

Running Queries in Threads

In order to successfully run queries in threads, you must follow a few cardinal rules:

For each thread you create that will be executing queries, you must have a separate instance of a TSession created along with the thread. (See Create constructor above)

Simply put, TSessions essentially define the multi-threadness of the BDE. The BDE requires separate TSessions to allow multiple access to shared resources. Failing to do this will cause some very strange things to occur in your program (it will crash with an BDE exception of some sort.)

Every data-access VCL component you instantiate within a thread must have its SessionName property set to that of the SessionName of the TSession created with your thread.

If you don't do this, the data-access component will default to the TSession created along with the main thread; this could have serious ramifications. If you assign components to a new TSession and forget to do so for others, when the components interact with each other with let's say a TBatchMove moving data from a query to a TTable, you'll get an error that says you're trying to perform an operation on objects in different sessions. Not good. So just to ensure that everything is safe, keep the data-access components you create in separate threads distinct by assigning the SessionNames to the SessionName of the TSession you create along with your thread.

You must create synchronized methods for any operation that will be accessing data-access components embedded on a form.

I can't stress enough the importance of performing any call that will access VCL components within a Synchronize call. You're looking for trouble if you don't. Let's say you run a background query that will provide information in a visual form in a TDBGrid. Running the query is the easy part. But once you're finished, you have to have a way of manipulating a TDataSource so that its DataSet property will point to the query you've run in the thread. Setting this must be done in a call to a synchronized method that does the setting for you.

Building on the previous rule, queries that will be providing data for data-aware components such as a TDBGrid must be persistent.

Once you free a thread, its resources are freed too. If you create a TQuery within the context of a TThread, your query is gone once the thread terminates and frees. The easiest thing to do then is to drop a TQuery on a form and run it from within the thread. That way, its handle remains valid even though the thread has finished its work.

Of the above rules, 1 and 2 are the most important elements for successfully running queries in separate threads of execution. While rules 3 and 4 are important, under certain conditions your queries will not run if you don't obey rules 1 and 2.

"Visual" and Non-visual Background Queries

Now that we've established ground rules regarding running queries in threads, we must take into consideration a couple of implementation paths. I put the visual in quotes above to denote queries whose results will be displayed in a data-aware component of some sort. Non-visual background queries don't provide any visual result. They just run, write to persistent data stores and return. How you implement these methods is significantly different -- we'll discuss them in separate sections below.

In either of these cases, the aim is to free up the user interface. One of my biggest frustrations with writing programs that process a lot of information is that once I've started execution, I can't do anything with the interface. I can't minimize or maximize the application; I can't move the window. Ever since I've learned to implement threaded technology in my programs, I need not worry about that. It's a real boon to my productivity.

Running Totally Background Queries

This method is a challenge; you have to code everything yourself. It's not a lot of code, but there are certain things to consider that you can take for granted when you drop VCL components onto a form. This method is very useful for "Data Mining" types of programs, in which you're querying huge tables and coming up with highly refined, summarized result sets. The operations that typify this type of application are several queries performed in succession. Were you to run this kind of application in a single-threaded program, you can effectively kiss your productivity goodbye because your user interface will be locked.

The example I'll be using for this discussion is the example I used above because that application is a data mining type of application. It was built to run several sequential queries against Paradox tables with hundreds of thousands of records (pretty big for Paradox tables).

Let's revisit the type declaration of thread:

type
  TEpiInfoProc = class(TThread)
    {Base processing class for Episode Information processing}
  private
    FStatMsg: string;
    FSession: TSession;
    tblPrimary,
      tblHistory,
      tblSymmetry: string;
    FIter: Integer;
    property Iteration: Integer read FIter write FIter;
    procedure eiCreateEpiTemp1; //Performs initial joins
    procedure eiCreateEpiTemp2; //Creates new table of summarized info
    procedure eiGetClassifications(clState, //'AMI', 'Asthma', etc.
      clName, //'H1', 'H2', etc.
      priFld, //Join field from Primary
      hstFld: string; //Join field from History
      bMode: TBatchMode); //Batch Mode (will always be
    //batCopy 1st time);
    procedure eiCreateEpiInfoTable(clSrc, clDst, clName: string);
    procedure eiCreateHistory(HistIndicator: string);

    //Generic processing methods
    procedure EnableBtns;
    procedure GetTableNames;
    procedure UpdStatus;
    procedure IndexTbl(dbName, tblName, idxName, fldName: string; idxOpts:
      TIndexOptions);
  protected
    procedure Execute; override;
  public
    constructor Create;
  end;

There's something in the type declaration that I didn't bring up previously. Notice the second private variable FSession. Then, look at the constructor Create code below:

constructor TEpiInfoProc.Create;
begin
  inherited Create(True);
  FSession := TSession.Create(Application);
  with FSession do
  begin
    SessionName := 'EpiInfoSession';
    NetFileDir := Session.NetFileDir;
    PrivateDir := 'D:\EpiPriv';
  end;
  FreeOnTerminate := True;
  Resume;
end;

I simply instantiate a new session in my Create constructor for my queries and tables to point to during the course of execution. If you don't have the latest update to Delphi and you look in the help file under TSession, you're warned not to create a TSession on the fly. Why? Truthfully, I don't know. I broke the rules anyway when I originally saw this warning because after looking at the VCL source for the TSession object in the DB.PAS file, I didn't see anything in the TSession object that would lead me to believe that I couldn't instantiate a TSession object on the fly. This changed in 2.01 -- the help file makes no such warning -- so it's not an issue. Of all the things that I'm doing in the thread, creating this TSession is the absolute key operation because it provides a common ground for all the data access components that I instantiate in the thread.

During the course of execution, I make calls to several procedures that perform queries on several different tables. However, they all operate similarly, so it's only necessary to list one of the procedures to illustrate how you should do your queries in a thread. Here's an example procedure:

procedure TEpiInfoProc.eiCreateEpiTemp1;
var
  sqlEI: TEnhQuery;
begin

  sqlEI := TEnhQuery.Create(Application);
  with sqlEI do
  begin
    SessionName := FSession.SessionName;
    DatabaseName := 'Primary';
    DestDatabaseName := 'PRIVATE';
    DestinationTable := 'epitemp1.db';
    DestBatchMoveMode := batCopy;
    DoBatchMove := True;
    with SQL do
    begin
      Clear;
      Add('SELECT DISTINCT d.Episode, d.PatientID, d.Paid AS TotPd, d.Charge AS TotChg, D1.Start');
      Add('FROM "' + tblPrimary + '" d LEFT OUTER JOIN "' + tblSymmetry + '" D1 ');
      Add('ON (D1.Episode = d.Episode)');
      Add('ORDER BY d.Episode, d.PatientID, d.Paid, d.Charge, D1.Start');
    end;
    try
      try
        Execute;
      except
        raise;
        Abort;
      end;
    finally
      Free;
    end;
  end;
end;

The important thing to notice in the code example above is that the first property I set for the query I create is its SessionName property. This falls in line with obeying rules 1 and 2 that I mentioned above. I did this first so I'd be in compliance with them right away, though you can set properties in any order. The whole point to this is that looking at the procedure, it's no different from any type of procedure you'd use to create a query and execute it in code. The only difference is that you don't rely on the default TSession; you use the one you created at construction time.

While I can't release what the application above actually does, I'll give you some gory details. On the average, the application requires three to four hours to execute completely, based on the size of the client database. Most of the client databases are several hundred megabytes in size, and all are in excess of 600MB per table, so you can imagine that with the enormity of the data sets, a single threaded application would just sit there and appear to be locked. But running the queries in the background frees the interface, so status messages can be supplied quite easily, and the form remains active during the run.

I took an easy way out in this program to prevent multiple threads from executing. Typically what you'll do is use a system mutex or a semaphore to provide a mechanism signaling that you have a process running. But I found it much easier to just disable all the buttons on the form, so the user could still move the form around and even enter selection criteria but couldn't execute the new process until the current process has finished. It took much less code to implement a disabling feature than to implement a system mutex.

Running Background Queries that will Produce Visible Result Sets

You won't need to do this often because typically, queries run to display data in a grid or some other data-aware component are usually run against smaller tables and execute fairly quickly, so you can get away with running a single thread of execution. There are some instances in which you might need to query a couple of unrelated tables at the same time, so running the queries in separate threads of execution makes a lot of sense.

Below is unit code from a test unit I wrote to illustrate this purpose. On my form I've dropped two of each of the following components: TQuery, TSession, TDataSource and a TDBGrid. I also have a button that will perform the thread creation. Let's look at the code, then discuss it:

unit thrtest;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DB,
    DBTables,
  Grids, DBGrids, StdCtrls;

type
  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Query1: TQuery;
    DBGrid1: TDBGrid;
    Button1: TButton;
    DataSource2: TDataSource;
    Query2: TQuery;
    DBGrid2: TDBGrid;
    Session1: TSession;
    Session2: TSession;
    procedure Button1Click(Sender: TObject);
  end;

  //Thread class declaration - very simple
  TQThread = class(TThread)
  private
    FQuery: TQuery;
  protected
    procedure Execute; override;
  public
    constructor Create(Query: TQuery);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

constructor TQThread.Create(Query: TQuery);
begin
  inherited Create(True); // Create thread in a suspendend state so we can prepare vars
  FQuery := Query; //Set up local query var to be executed.
  FreeOnTerminate := True; //Free thread when finished executing
  Resume;
end;

procedure TQThread.Execute;
begin
  FQuery.Open; //Perform the query
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  TQThread.Create(Query1);
  TQThread.Create(Query2);
end;

end.

I've made the thread intentionally easy. The only thing you pass to the constructor is a query. The rest is all taken care of.

Before I did any coding of the above, I did the following with the components on the form:

DataSource1 and DataSource2 have their DataSet properties set to Query1 and Query2, respectively. Likewise, DBGrid1 and DBGrid2 have their DataSource properties set to DataSource1 and DataSource2, respectively.
Query1 and Query2 have their SessionName property set to the SessionName property of Session1 and Session2, respectively.
Both TQuerys have their DatabaseName properties set to DBDEMOS. Query1's SQL is simple : 'SELECT * FROM "employee.db".' Query2's SQL is simple as well: 'SELECT * FROM "customer.db".'

This is a really simplistic example that works amazingly well. When the user presses the button, the program creates two new threads of type TQThread. Since we pass in the query we want to execute, the thread knows which one to operate on.

Notice that I didn't put any synchronization code in this example. Some might think that you have to do this for a DataSource component, but the DataSource is Session-less, so it's impossible. Besides, the DataSource is merely a conduit between the Query and the DBGrid. It's fairly inert.

As in any program, you can make this much more complex. For example, you can set the DatabaseName and SQL of the TQuerys at runtime, making this a really flexible display tool. You can add a batchmove facility at the tail-end of the run so that in addition to displaying the results in a DBGrid, the program will also write to result tables. Play around with this to see how you can expand on the concept.

Conclusion

Multi-threading is a breakthrough and revolutionary programming technology for many programmers. Note, that on Unix systems, multithreading has existed for several years. But for Windows platforms, this hasn't been the case until a few years ago. Also, I didn't cover some of the really advanced stuff that you can do with threads. For that, you'll have to refer to advanced-level Win32 development books. But hopefully, in the course of this discussion, you've reached a level of understanding that will get you on your way to constructing your own multi-threaded applications.