How to create nodes and subnodes of a TTreeView at runtime to represent a master - detail relationship

Problem/Question/Abstract:

I would like to present a master - detail relationship within a TTreeView upon opening a query at runtime. Getting the correct info is not a problem but I'm totally stumped by the use of a TTreeView. Are there commands usable at runtime to enable me to create and edit the nodes/ sub nodes of the treeview to present the master records as nodes and the detail records as sub nodes within the treeview?

Answer:

Here's an example of creating / maintaining TreeNodes at runtime. Before I take off, I assume that you use database tables like the following:

A MASTERTABLE, with fields M_ID (unique identifier) and M_NAME (a descriptive name);
A DETAILTABLE, with fields D_ID (unique identifier), D_NAME (a descriptive name), and D_M_ID (a foreign key value that links the detail record to a master record.)

This could be quite different from what you have, but I need to make assumptions in order to write this example.

The first step of the process is to add all master records as parent nodes of detail nodes. It goes without saying that I need to add parent nodes first, since detail nodes are 'dependent' of them.

You can add all master records to the TreeView by looping the query at runtime and do something like this:

{Get all master records in query}
{ ... }
while not qryMasterRecords.EOF do
begin
  {some code will follow here, be patient my friend.}
  TreeView1.Items.Add(nil, qryMasterRecords.FieldByName('M_NAME').AsString);
  qryMasterRecords.Next;
end;
{ ... }

The Add method (of a TTreeNodes object) adds the node to the TreeView; the first parameter specifies the parent node. (in this case, nil means that it is added as a root node.) The second parameter is the node name that is represented in the TreeView. (this is the Text property of a TTreeNode.)

However, I am finished yet with the master records. How the heck am I going to identify the master nodes when I want to insert detail nodes later on? When adding a detail node, I need to know what its parent should be. A bad answer (to me) is to say that one can use the node name as an identifier. Since we have a unique identifier for each master record in the database, why don't we use it?

The solution to this lies in the Data property of the TreeNode object: This is a pointer one can assign to an application-designed object. The intention is to use such an object to store the unique identifier of the master record.

Let's use an record-type object like this:

type
  PMaster = ^TMaster
    TMaster = record
    Identifier: integer;
  end;

Assuming these types are used, I modify the master-node-adding code to this:

{ ... }
var
  MasterPtr: PMaster;
  { ... }
  {Get all master records in query}
  { ... }
  while not qryMasterRecords.EOF do
  begin
    New(MasterPtr);
    Master^.Identifier := qryMasterRecords.FieldByname('M_ID').AsInteger);
  TreeView1.Items.AddObject(nil, qryMasterRecords.FieldByName('M_NAME').AsString,
    MasterPtr);
  qryMasterRecords.Next;
end;
{ ... }

At runtime, I create a record type object for each record that is found in the query. I use a slightly extended version of the Add method. AddObject also links MasterPtr with the Data property of the new node.

For now, I have finished with the master nodes: The next step is to add all detail nodes. I need to write a small function that searches for a TreeNode with a specified M_ID value. I need this while adding detail nodes, because I need to identify a node that is the parent node of the detail node that is to be inserted.

function SearchMasterNode(iM_ID: integer): TTreeNode;
{Searches for a node with a specified M_ID value. Returns the TreeNode that has the
specified M_ID value. When it is not found, nil is returned.}
var
  iCount: integer;
begin
  {Default value to return}
  Result := nil;
  {For your info: iterating like this loops through all nodes in a TreeView, including detail nodes}
  for iCount := 0 to TreeView1.Items.Count - 1 do
  begin
    if Assigned(TreeView1.Items.Item[iCount].Data) then
      if PMaster(TreeView1.Items.Item[iCount].Data)^.Identifier = iM_ID then
        Result := TreeView1.Items.Item[iCount];
    {We got a match !}
  end;
end;

From now on, adding detail nodes is much like adding master nodes, with one extra move: a search for a parent node.

{ ... }
{Insert all master nodes to the TreeView}
{ ... }
var
  MasterNode: TTreeNode;

  {Get all detail records in query}
  { ... }
  while not qryDetailRecords.EOF do
  begin
    MasterNode := SearchMasterNode(qryDetailRecords.FieldByName('D_M_ID').AsInteger);
    {For your info: The Data property of this new node is set to nil.}
    TreeView1.Items.AddChild(MasterNode,
                                                                                                        qryDetailRecords.FieldByName('D_NAME').AsString);
    qryDetailRecords.Next;
  end;

The Add method is used here, since I assume that you don't need to identify detail nodes for something else. When you do need this (for example, clicking on a detail node must result in the representation of detail record data in edit boxes, memo-boxes, whatever input control.) use the approach with master nodes.

Finally, to create an application that uses computer memory efficiently, I should free all memory used for the record-type objects. I did this by iterating through all nodes and freeing the data objects:

{ ... }
var
  iCount: integer;
  { ... }
  for iCount := 0 to TreeView1.Items.Count - 1 do
  begin
    if Assigned(TreeView1.Items.Item[iCount].Data) then
      Dispose(TreeView1.Items.Item[iCount].Data);
  end;
  {Finally, free all nodes constructed at runtime}
  TreeView1.Items.Clear;
  { ... }

How to check if a user has administrator rights in NT

Problem/Question/Abstract:

How to check if a user has administrator rights in NT

Answer:

{ ... }
const
  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));

const
  SECURITY_BUILTIN_DOMAIN_RID = $00000020;
  DOMAIN_ALIAS_RID_ADMINS = $00000220;

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

How to send messages to threads

Problem/Question/Abstract:

I'm having a problem sending messages to my threads. I can send back to parent form very easily with PostMessage, but I have tried to communicate to my threads via PostMessage and PostThreadMessage to no avail. I read some cryptic remarks in the PostThreadMessage help that seemed to indicate that I would have to induce the API into creating a message queue for the thread. Can anyone shed some light?

Answer:

type
  TMyThread = class(TThread)
    AHwnd: HWND;
    procedure Execute; override;
    procedure Terminate;
    destructor Destroy; override;
  end;

procedure TMyThread.Execute;
var
  msg: TMsg;
  MyTerminated: Boolean;
begin
  MyTerminated := False;
  while not MyTerminated do
  begin
    WaitMessage;
    if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
    begin
      TranslateMessage(Msg);
      case Msg.Message of
        WM_QUIT: MyTerminated := True;
        WM_USER: PostMessage(AHwnd, WM_USER, 0, GetTickCount);
      end;
    end;
  end;
end;

procedure TMyThread.Terminate;
begin
  PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
  inherited;
end;

destructor TMyThread.Destroy;
begin
  Terminate;
  inherited;
end;

var
  MyThread: TMyThread;

procedure TForm1.WMUser(var msg: TMessage); {message WM_USER;}
begin
  Caption := IntToStr(msg.LParam);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyThread := TMyThread.Create(False);
  MyThread.AHwnd := Handle;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  PostThreadMessage(MyThread.ThreadID, WM_USER, 0, 0);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  MyThread.Free;
end;

Register your own file extensions in the Windows registry

Problem/Question/Abstract:

I have an application that create files. I want those files to be associated to my application so that when you double click on those files will launch my application and open the particular file. How do I do this?

Answer:

Take a look at the registry (HKEY_CLASSES_ROOT) to see what exactly is possible. Basically, you have to add an entry that equals the file extension, one that equals an unique name and the action. And you have to tell Windows that you have registered a new extension. Something like:

{ ... }
var
  Regist: TRegistry;
begin
  Result
    Regist := TRegistry.Create;
  try
    Regist.RootKey := HKEY_CLASSES_ROOT;
    {file type}
    if Regist.OpenKey('.xyz' {= your extension}, True) then
    begin
      Regist.WriteString('', 'xyz-file' {= unique name});
      Regist.CloseKey;
    end;
    {name}
    if Regist.OpenKey('xyz-file' {= same unique name}, True) then
    begin
      Regist.WriteString('', 'xyz super file'
        {= short description, is shown in explorer});
      Regist.CloseKey;
    end;
    {icon}
    if Regist.OpenKey('xyz-file\DefaultIcon', True) then
    begin
      {third icon of your exe, 0 is the main icon I think, of course you can use
                        other files than Application.ExeName}
      Regist.WriteString('', Application.ExeName + ', 3');
      Regist.CloseKey;
    end;
    {open}
    if Regist.OpenKey('xyz-file\Shell\Open\Command', True) then
    begin
      Regist.WriteString('', Application.ExeName + ' "%1"');
        {or other/ additional parameters}
      Regist.CloseKey;
      Result := True;
    end;
    {you can add more for edit, print etc.}
    SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
    {tell Windows we have done it}
  finally
    Regist.Free;
  end;
end;

How to draw a frame around a TImage

Problem/Question/Abstract:

How to draw a frame around a TImage

Answer:

unit paintframe;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private Declarations}
  public
    procedure drawtheframe(Fwidth: Integer; colr: TColor);
    procedure Hideframe;
    procedure Showframe;
  end;

var
  Form1: TForm1;

const
  Fwidth = 2;
  There: boolean = false;

implementation

{$R *.DFM}

procedure TForm1.drawtheframe(Fwidth: Integer; colr: TColor);
var
  z: Integer;
begin
  z := ord(not (odd(Fwidth)));
  canvas.brush.style := bsClear;
  canvas.pen.width := Fwidth;
  canvas.pen.color := colr;
  Fwidth := width1 - (Fwidth div 2);
  canvas.rectangle(image1.left - Fwidth, image1.top - Fwidth, image1.left + image1.width
    + Fwidth + z, image1.top + image1.height + Fwidth + z);
end;

procedure TForm1.Showframe;
begin
  drawtheframe(Fwidth, clBlue);
  There := true;
end;

procedure TForm1.Hideframe;
begin
  There := false;
  drawtheframe(Fwidth, color);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  if There then
    Showframe;
end;

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

procedure TForm1.Button2Click(Sender: TObject);
begin
  Hideframe;
end;

end.

How to copy one TRichEdit to another

Problem/Question/Abstract:

How to copy one TRichEdit to another

Answer:

type
  TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;
    cb: Longint; var pcb: Longint): DWORD; stdcall;

  TEditStream = record
    dwCookie: Longint;
    dwError: Longint;
    pfnCallback: TEditStreamCallBack;
  end;

function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;
  cb: Longint; var pcb: Longint): DWORD; stdcall;
var
  theStream: TStream;
  dataAvail: LongInt;
begin
  theStream := TStream(dwCookie);
  with theStream do
  begin
    dataAvail := Size - Position;
    Result := 0; {assume everything is ok}
    if dataAvail <= cb then
    begin
      pcb := Read(pbBuff^, dataAvail);
      if pcb <> dataAvail then {couldn't read req. amount of bytes}
        result := E_FAIL;
    end
    else
    begin
      pcb := Read(pbBuff^, cb);
      if pcb <> cb then
        result := E_FAIL;
    end;
  end;
end;

function EditStreamOutCallback(dwCookie: Longint; pbBuff: PByte; cb:
  Longint; var pcb: Longint): DWORD; stdcall;
var
  theStream: TStream;
begin
  theStream := TStream(dwCookie);
  with theStream do
  begin
    if cb > 0 then
      pcb := Write(pbBuff^, cb);
    Result := 0;
  end;
end;

procedure GetRTFSelection(aRichEdit: TRichEdit; intoStream: TStream);
var
  editstream: TEditStream;
begin
  with editstream do
  begin
    dwCookie := Longint(intoStream);
    dwError := 0;
    pfnCallback := EditStreamOutCallBack;
  end;
  aRichedit.Perform(EM_STREAMOUT, SF_RTF or SFF_SELECTION, longint(@editstream));
end;

procedure PutRTFSelection(aRichEdit: TRichEdit; sourceStream: TStream);
var
  editstream: TEditStream;
begin
  with editstream do
  begin
    dwCookie := Longint(sourceStream);
    dwError := 0;
    pfnCallback := EditStreamInCallBack;
  end;
  aRichedit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, longint(@editstream));
end;

procedure InsertRTF(aRichEdit: TRichEdit; s: string);
var
  aMemStream: TMemoryStream;
begin
  if Length(s) > 0 then
  begin
    aMemStream := TMemoryStream.Create;
    try
      aMemStream.Write(s[1], length(s));
      aMemStream.Position := 0;
      PutRTFSelection(aRichEdit, aMemStream);
    finally
      aMemStream.Free;
    end;
  end;
end;

procedure CopyRTF(aSource, aDest: TRichEdit);
var
  aMemStream: TMemoryStream;
begin
  aMemStream := TMemoryStream.Create;
  try
    GetRTFSelection(aSource, aMemStream);
    aMemStream.Position := 0;
    PutRTFSelection(aDest, aMemStream);
  finally
    aMemStream.Free;
  end;
end;

Enumerate all network resources

Problem/Question/Abstract:

Enumerate all network resources

Answer:

The following routine DoEnumeration enumerates all network resources and puts the server names in a listbox ListBox1. In the given application this was used to select an application server.

function Fix(Server: string): string;
var
  p: integer;
begin { Fix }
  // dirty & slow, but it works :-)
  while copy(Server, 1, 1) = '\' do
    delete(Server, 1, 1);
  p := pos('\', Server);
  if p > 0 then
    delete(Server, p, 999);

  Result := Server
end; { Fix }

procedure TFSelServer.DoEnumeration;
type
  PNetResourceArray = ^TNetResourceArray;
  TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
var
  I, Count, BufSize, Size, NetResult: Integer;
  NetHandle: THandle;
  NetResources: PNetResourceArray;
  Server: string;
begin { DoEnumeration }
  if WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, 0, nil, NetHandle) <> NO_ERROR
    then
    Exit;

  try
    BufSize := 50 * SizeOf(TNetResource);
    GetMem(NetResources, BufSize);
    try
      while True do
      begin { while Tr.. }
        Count := -1;
        Size := BufSize;
        NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
        if NetResult = ERROR_MORE_DATA then
        begin
          BufSize := Size;
          ReallocMem(NetResources, BufSize);
          Continue;
        end;
        if NetResult <> NO_ERROR then
          Exit;
        for I := 0 to Count - 1 do
          with NetResources^[I] do
          begin { with Net.. }
            Server := Fix(lpRemoteName);
            if ListBox1.Items.IndexOf(Server) < 0 then
              ListBox1.Items.Add(Server)
          end; { with Net.. }
      end; { while Tr.. }
    finally
      FreeMem(NetResources, BufSize);
    end; { try }
  finally
    WNetCloseEnum(NetHandle);
  end; { try }
end; { DoEnumeration }

Retrieve clipboard data in RTF tokens

Problem/Question/Abstract:

I'm trying to retrieve clipboard data in RTF tokens, and I can't figure out how to do it. Here's the scenario: 1. Create rich text in (eg) WordPad, including bold, italics etc., 2. Copy that to the clipboard., 3. Paste it into a TRichEdit. The pasted data includes all the formatting info. However, if I try to get that data off the clipboard myself, using Clipboard.AsText, or getting a handle to it with CF_TEXT, what I get is plain text, minus the formatting. It seems to me there should be a way to get RTF tokens from the clipboard, but neither the Delphi docs nor the MS documentation lists any format that could include rich text. There is no such format as CF_RICHTEXT. Anybody know how I can do this? Am I completely wrong to assume that RTF tokens are even being passed through the clipboard in the above scenario?

Answer:

uses
  RichEdit;

function GetRawRTFFromClipboard: string;
var
  H: THandle;
  TextPtr: PChar;
  CurrentFormat: Integer;
  NameLen: DWord;
  NameStr: string;
begin
  Result := '';
  ClipBoard.Open;
  try
    CurrentFormat := EnumClipboardFormats(0);
    while CurrentFormat <> 0 do
    begin
      NameLen := 1024;
      SetLength(NameStr, NameLen);
      NameLen := GetClipboardFormatName(CurrentFormat, PChar(NameStr), NameLen);
      SetLength(NameStr, NameLen);
      if CompareText(NameStr, CF_RTF) = 0 then
        Break;
      CurrentFormat := EnumClipboardFormats(CurrentFormat);
    end;
    if CurrentFormat = 0 then
      raise Exception.Create('Data on clipboard is not RTF');
    H := Clipboard.GetAsHandle(CurrentFormat);
    TextPtr := GlobalLock(H);
    Result := StrPas(TextPtr);
    GlobalUnlock(H);
  finally
    Clipboard.Close;
  end;
end;

How to print a file directly to a printer

Problem/Question/Abstract:

How to print a file directly to a printer

Answer:

Solve 1:

uses
  WinSpool;

procedure PrintFile(const sFileName: string);
const
  BufSize = 16384;
type
  TDoc_Info_1 = record
    pDocName: pChar;
    pOutputFile: pChar;
    pDataType: pChar;
  end;
var
  Count, BytesWritten: integer;
  hPrinter: THandle;
  Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDeviceMode: THandle;
  DocInfo: TDoc_Info_1;
  f: file;
  Buffer: Pointer;
begin
  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not WinSpool.OpenPrinter(@Device, hPrinter, nil) then
    exit;
  DocInfo.pDocName := 'MyDocument';
  DocInfo.pOutputFile := nil;
  DocInfo.pDatatype := 'RAW';
  if StartDocPrinter(hPrinter, 1, @DocInfo) = 0 then
  begin
    WinSpool.ClosePrinter(hPrinter);
    exit;
  end;
  if not StartPagePrinter(hPrinter) then
  begin
    EndDocPrinter(hPrinter);
    WinSpool.ClosePrinter(hPrinter);
    exit;
  end;
  System.Assign(f, sFileName);
  try
    Reset(f, 1);
    GetMem(Buffer, BufSize);
    while not eof(f) do
    begin
      Blockread(f, Buffer^, BufSize, Count);
      if Count > 0 then
      begin
        if not WritePrinter(hPrinter, Buffer, Count, BytesWritten) then
        begin
          EndPagePrinter(hPrinter);
          EndDocPrinter(hPrinter);
          WinSpool.ClosePrinter(hPrinter);
          FreeMem(Buffer, BufSize);
          exit;
        end;
      end;
    end;
    FreeMem(Buffer, BufSize);
    EndDocPrinter(hPrinter);
    WinSpool.ClosePrinter(hPrinter);
  finally
    System.Closefile(f);
  end;
end;

procedure WriteRawStringToPrinter(PrinterName: string; S: string);
var
  Handle: THandle;
  N: DWORD;
  DocInfo1: TDocInfo1;
begin
  if not OpenPrinter(PChar(PrinterName), Handle, nil) then
  begin
    ShowMessage('error ' + IntToStr(GetLastError));
    Exit;
  end;
  with DocInfo do
  begin
    pDocName := PChar('test doc');
    pOutputFile := nil;
    pDataType := 'RAW';
  end;
  StartDocPrinter(Handle, 1, ocInfo);
  StartPagePrinter(Handle);
  WritePrinter(Handle, PChar(S), Length(S), N);
  EndPagePrinter(Handle);
  EndDocPrinter(Handle);
  ClosePrinter(Handle);
end;

The PrinterName parameter must be the name of the printer as it is installed. For example, if the name of the printer is "HP LaserJet 5MP" then that is what you should pass.


Solve 2:

The procedure below spools a RAW PCL file to the printer. Mainly you need to use the WritePrinter API call along with OpenPrinter.

procedure PrintPCL;
var
  Handle: THandle;
  numwrite: DWORD;
  Docinfo1: TDocInfo1;
  PrintFile, InFile, SampForm: TMemoryStream;
  buffer: array[0..4096] of char;
  HPLetter, HPLegal, NC: array[0..15] of char;
  temp: array[0..3] of char;
  FF: char;
  numread: longint;
  x: integer;
  FileName: string;
begin
  if (OpenPrinter(PrinterName, Handle, nil)) then
  begin
    FF := Chr(12);
    strcopy(HPLetter, chr(27));
    strcat(HPLetter, '&l6d66p1h2A');
    strcopy(HPLegal, chr(27));
    strcat(HPLegal, '&l6d84p4h3A');
    strcopy(NC, chr(27));
    strcat(NC, '&l');
    strcat(NC, StrPCopy(temp, InttoStr(NumCopies)));
    strcat(NC, 'X');
    try
      PrintFile := TMemoryStream.Create;
      for x := 0 to Printlist.Count - 1 do
      begin
        FileName := Copy(PrintList[x], 1, pos(',', printlist[x]) - 1);
        InFile := TMemoryStream.Create;
        InFile.LoadFromFile(FileName);
        if (Integer(filename[Length(FileName) - 1]) = 49) then
          PrintFile.Write(HPLetter, Strlen(HPLetter))
        else
          PrintFile.Write(HPLegal, Strlen(HPLegal));
        PrintFile.Write(NC, strlen(NC));
        PrintFile.CopyFrom(InFile, 0);
        InFile.Free;
        if Sample then
        begin
          try
            SampForm := TMemoryStream.Create;
            SampForm.LoadFromFile(AppPath + 'SAMPLE.PRN');
            PrintFile.Copyfrom(SampForm, 0);
          finally
            SampForm.Free;
          end;
        end;
        PrintFile.Write(FF, SizeOf(FF));
      end;
      DocInfo1.pDocName := PChar('PCLPrinter');
      DocInfo1.pOutputFile := nil;
      DocInfo1.pDataType := 'RAW';
      PrintFile.Seek(0, 0);
      StartDocPrinter(Handle, 1, @DocInfo1);
      StartPagePrinter(Handle);
      numread := 0;
      numwrite := 0;
      while (numread = numwrite) and (PrintFile.Position <> PrintFile.Size) do
      begin
        numread := PrintFile.Read(buffer, sizeof(buffer));
        WritePrinter(Handle, @buffer, numread, numwrite);
        UpdateProgress(round((PrintFile.Position / PrintFile.Size) * 100));
      end;
      EndPagePrinter(Handle);
      EndDocPrinter(Handle);
      ClosePrinter(Handle);
    finally
      PrintFile.Free;
    end;
  end;
end;

How to draw multiple columns in a TComboBox

Problem/Question/Abstract:

How to draw multiple columns in a TComboBox

Answer:

You can go with a custom drawn combo box:

unit Unit1;

interface

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

type

  TDataRec = class(TObject)
  private
    Str1: string;
    Str2: string;
  end;

  TForm1 = class(TForm)
    DeleteListBox1: TListBox;
    Header1: THeader;
    Image1: TImage;
    ComboBox1: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
      State: TOwnerDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  DataRec: TDataRec;
begin
  for i := 1 to 10 do
  begin
    DataRec := TDataRec.Create;
    with DataRec do
    begin
      Str1 := 'String1 ' + IntToStr(i);
      Str2 := 'String2 ' + IntToStr(i);
    end;
    ComboBox1.Items.AddObject('', DataRec);
  end;
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  S1, S2: string;
  TempRect: TRect;
begin
  S1 := TDataRec(ComboBox1.Items.Objects[Index]).Str1;
  S2 := TDataRec(ComboBox1.Items.Objects[Index]).Str2;
  ComboBox1.Canvas.FillRect(Rect);
  TempRect := Rect;
  TempRect.Right := Header1.SectionWidth[0];
  ComboBox1.Canvas.StretchDraw(TempRect, Image1.Picture.Graphic);
  Rect.Left := Rect.Left + 50;
  DrawText(ComboBox1.Canvas.Handle, PChar(S1), Length(S1), Rect, dt_Left or dt_VCenter);
  Rect.Left := Rect.Left + 100;
  DrawText(ComboBox1.Canvas.Handle, PChar(S1), Length(S1), Rect, dt_Left or dt_VCenter);
end;

end.

Distributable COM Objects on Remote Machines

Problem/Question/Abstract:

Distributable COM Objects on Remote Machines

Answer:

There is not much documentation around on DCOM. DCOM is similar to COM except that the objects reside and are registered on remote machines.

In this article I demonstrate how to connect to and execute remote COM objects (your own or 3rd party). The objects must support the IDISPATCH interface (majority do).

Those of you familiar with the function CreateOleObject() will be quite comfortable with the approach, others can search the Internet for "COM" articles to clarify this technique.

The Windows DCOMCNFG.EXE, which allows permission and properties to be maintained by the remote machine is also discussed.

The article was written using platforms Delphi 5 and Win2000. I do not know if this approach works on lesser versions as I do not have access to them..


The function commonly used to connect to COM/OLE objects is CreateOleObject().
eg. Ole := CreateOleObject(&#8216;word.application&#8217;);

The connection to a DCOM object is not that different in concept except that we use the GUID of the object class instead of the Classname string, CreateComObject() also uses the GUID.

The function we use to implement DCOM in Delphi is CreateRemoteComObject(), which resides in unit ComObj.

Definition
function CreateRemoteComObject(const MachineName: WideString;
                               const ClassID: TGUID): IUnknown;

The MachineName is a string of the Target machine that you want to run the Object on.

eg.  &#8216;mheydon&#8217;

The ClassID is the GUID of the object that is found in the registry under key HKEY_LOCAL_MACHINE\Software\CLSID.

eg. const PUNK : TGUID = '{000209FF-0000-0000-C000-000000000046}';

Refer to my article &#8220;COM/OLE Object Name Utility Procedure &#8221; for an easy way to browse for these GUIDs

The function (if successful) returns an IUNKNOWN interface. We require an IDISPATCH interface, thus we will simply use Delphi&#8217;s typecasting feature.

A trivial example of a user written COM/OLE application is as follows. The method BirthDate() simply returns a string containing the birthdate of the given age in years from the target machine.



uses ComObj;

// GUID of my test object &#8216;serv.server&#8217;
const
  PUNK: TGUID = '{74A5EC07-DC84-4C65-8944-1A2315A550FB}';

procedure TForm1.Button1Click(Sender: TObject);
var
  Ole: OleVariant;
  BDate: WideString;
begin
  // Create the object as IDISPATCH
  Ole := CreateRemoteComObject('mheydon', PUNK) as IDispatch;

  Ole.BirthDate(46, BDate); // Method of 'serv.server'
  showmessage(BDate);

  Ole := VarNull; // Free object and deactivate
end;


As you can see it is a very simplified example (without error checking), but the prime objective was to display the DCOM connectivity in a clear way.


The other thing that affects the DCOM object on the target machine is permissions and other properties. If you are getting &#8220;Access Denied&#8221; or want to change the behaviour of the remote object then run the Windows utility DCOMCNFG.EXE. This has many options and a summary is as follows.


Main form. Select your object here and set it&#8217;s properties. Be careful if playing with any of the DEFAULT tabs as they will affect ALL your objects.

General. All you change here is Authentication level. Not sure what affects all the different options have.

Location. Where to run the application.

Security. If you are getting Access Denied errors when connecting then you can modify or add users here.

Identity. This is similar to setting the user of a Windows Service. If you want to be able to kill the process from task manager then you should set this option to &#8220;This users&#8221; where the user is the current user of the machine, or else task manager will tell you that you have no permissions to kill the process.

Endpoints. Have absolutely no idea what this page does. Some light anyone ?

How to save and restore font properties in the registry (2)

Problem/Question/Abstract:

I was just wondering what the best way to save a particular font to the registry would be. Do I have to save each of its attributes separately? Is there an easier way than storing it to the registry, perhaps? Seems like such a simple issue, but other than saving and loading each attribute separately, I can't think of a way to do it at one time!

Answer:

You can do it by getting a TLogfont record filled and save that to a binary key:


var
  lf: TLogfont;
begin
  fillchar(lf, sizeof(lf), 0);
  GetObject(font.handle, sizeof(lf), @lf);
  registry.WriteBinarydata(valuename, lf, sizeof(lf));
end;


Reading it back would go like this:


registry.ReadBinarydata(valuename, lf, sizeof(lf));
font.handle := CreateFontIndirect(lf);


A probably more Kylix-compatible method would be to create a non-visual wrapper component for a TFont and stream that, e.g. to a memory stream. The streams content could then be saved to a binary registry key.


type
  TFontWrapper = class(TComponent)
  private
    FFont: TFont;
    procedure SetFont(f: TFont);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Font: TFont read FFont write SetFont;
  end;

constructor TFontWrapper.Create(AOwner: TComponent);
begin
  inherited Create(aOwner);
  FFont := TFont.Create;
end;

destructor TFontWrapper.Destroy;
begin
  FFont.Free;
  inherited Destroy;
end;

procedure TFontWrapper.SetFont(f: TFont);
begin
  FFont.Assign(f);
end;

procedure TScratchMain.SpeedButton2Click(Sender: TObject);
const
  b: Boolean = False;
var
  fw: TFontWrapper;
  st: TFileStream;
begin
  if b then
  begin
    edit1.text := 'Loading font';
    fw := nil;
    st := TFileStream.Create('E:\A\test.str', fmOpenRead);
    try
      fw := TFontWrapper.Create(nil);
      st.ReadComponent(fw);
      memo1.font.assign(fw.font);
    finally
      fw.Free;
      st.Free;
    end;
  end
  else
  begin
    edit1.text := 'Saving font';
    fw := nil;
    st := TFileStream.Create('E:\A\test.str', fmCreate);
    try
      fw := TFontWrapper.Create(nil);
      fw.Font := Font;
      st.WriteComponent(fw);
    finally
      fw.Free;
      st.Free;
    end;
  end;
  b := not b;
end;

How to use a loop to catch edit control values

Problem/Question/Abstract:

I want to check if the user has filled all required DBEdit controls on a notebook, before enabling a button on the form.

Answer:

If you dropped the controls onto the notebook at design time, their Owner will be the form not the notebook. This means that it will not belong to the Components array of the notebook, but of the form. The Notebook's Controls array will be all the controls it parents and that is probably the array you want to loop through.

procedure TAddFrm.SetNextBtn;
var
  I: Integer;
  fld: TControl;
  fldEmpty: Boolean;
begin
  fldEmpty := False;
  with Notebook do
  begin
    for I := 0 to ControlCount - 1 do
    begin
      fld := Controls[i];
      if (fld is TDBEdit) then
      begin
        fldEmpty := TDBEdit(fld).GetTextLen = 0;
        if fldEmpty then
          Break;
      end
    end;
    AddfrmNextBtn.Enabled := not fldEmpty;
  end;
end;

if fldName is TCustomEdit then
  fldEmpty := TCustomEdit(fldName).GetTextLen = 0;

How to rotate a 2D point

Problem/Question/Abstract:

How to rotate a 2D point

Answer:

In 2-D, the 2 x 2 matrix is very simple. If you want to rotate a column vector v by t degrees using matrix M, use



M = {{cos t, -sin t}, {sin t, cos t}}



in M * v.

If you have a row vector, use the transpose of M (turn rows into columns and vice versa). If you want to combine rotations, in 2-D you can just add their angles, but in higher dimensions you must multiply their matrices.

How to determine the size of a file

Problem/Question/Abstract:

How to determine the size of a file

Answer:

Solve 1:

You can use the type TSearchRec as follows:

function LoadSize(Path: string): integer;
var
  Rec: TSearchRec;
begin
  Result := 0;
  if FindFirst(Path, faAnyFile, Rec) = 0 then
  begin
    Result := Rec.Size;
    FindClose(Rec);
  end;
end;


Solve 2:

{ ... }
var
  fileInfo: _WIN32_FILE_ATTRIBUTE_DATA;
  totalSize: Int64;
begin
  GetFileAttributesEx(PChar(EdtPath.Text), GetFileExInfoStandard, @fileInfo);
  totalSize := fileInfo.nFileSizeHigh shl 32 or fileInfo.nFileSizeLow;
end;


Solve 3:

{ ... }
var
  SR: TSearchRec;
  FileName: string;
  r: integer;
begin
  FileName := 'c:\winnt\system32\shell32.dll';
  r := FindFirst(FileName, faAnyFile, SR);
  if r = 0 then
  begin
    Label1.Caption := Format('Size of %s is %d bytes (%0.1f Mb)',
      [FileName, SR.Size, Sr.Size / 1000000]);
    FindClose(SR);
  end
  else
    Label1.Caption := 'File does not exist';
end;


Solve 4:

procedure TForm1.Button1Click(Sender: TObject);
var
  hFile: THandle;
  Size: Integer;
begin
  if OpenDialog1.Execute then
  begin
    hFile := FileOpen(OpenDialog1.FileName, fmOpenRead or fmShareDenyNone);
    Size := GetFileSize(hFile, nil);
    {CloseHandle: use to close handle created with CreateFile which is
                what FileOpen calls internally}
    CloseHandle(hFile);
    ShowMessage(Format('Size in bytes: %d', [Size]));
  end;
end;

Display text diagonally

Problem/Question/Abstract:

Display text diagonally

Answer:

To display text diagonally (or by any other degree), you need to create a font. The font may be created using the function CreateFontIndirect. The parameter's record member .lfOrientation specifies the angle in 0.1 degrees, e.g. 450 equals 45 degrees.

When the font handle is no longer needed, it should be deleted with DeleteObject().

The following function writes a sort of watermark on a DC and uses the API function TextOut for this:


procedure Draw_Watermark_on_DC(const aDC: hDC; const x, y: integer);
var
  plf: TLOGFONT;
  hfnt, hfntPrev: HFONT;
const
  txt1: PChar = 'Created with the demo version of'#0;
  txt2: PChar = '      pasDOC'#0;
  WaterMarkWidth = 300;
  WaterMarkHeight = 300;
begin
  // Specify a font typeface name and weight.
  ZeroMemory(@plf, sizeof(plf));
  lstrcpy(plf.lfFaceName, 'Arial');
  plf.lfHeight := 30;
  plf.lfEscapement := 0;
  plf.lfOrientation := 450;
  plf.lfWeight := FW_NORMAL;
  plf.lfCharset := ANSI_CHARSET;
  plf.lfOutPrecision := OUT_TT_PRECIS;
  plf.lfQuality := PROOF_QUALITY;
  hfnt := CreateFontIndirect(plf);

  // Draw the rotated string
  SetBkMode(aDC, TRANSPARENT);
  hfntPrev := SelectObject(aDC, hfnt);
  Windows.TextOut(aDC, x, y + WaterMarkHeight - 25, txt1, strlen(txt1));
  Windows.TextOut(aDC, x + plf.lfHeight * 3, y + WaterMarkHeight - 25, txt2,
    strlen(txt2));
  SelectObject(aDC, hfntPrev);
  DeleteObject(hfnt);
end;

How to create only one instance of a MDI child form (4)

Problem/Question/Abstract:

What is the best way to avoid a form being created more than once in a MDI application?

Answer:

unit WindowFunctions;

interface

uses
  Classes, Forms;

function IsChildWindow(AFormClass: TFormClass; AiTag: integer): Boolean;
procedure CreateChildWin(AOwner: TComponent; AFormClass: TFormClass; AiTag: integer);

implementation

uses
  Dialogs, Controls;

function IsChildWindow(AFormClass: TFormClass; AiTag: integer): boolean;
var
  i: integer;
begin
  Result := False; {The window does not exist}
  for i := 0 to (Screen.FormCount - 1) do
  begin
    if (Screen.Forms[i] is AFormClass) and (AiTag = Screen.Forms[i].Tag) then
    begin
      {The window was found}
      Screen.Forms[i].BringToFront;
      Result := True;
      break;
    end;
  end;
end;

procedure CreateChildWin(AOwner: TComponent; AFormClass: TFormClass; AiTag: integer);
begin
  if not IsChildWindow(AFormClass, AiTag) then
  begin
    with AFormClass.Create(AOwner) do
    begin
      Tag := AiTag;
    end;
  end;
end;

end.

Test if a string is a valid file name

Problem/Question/Abstract:

Test if a string is a valid file name

Answer:

The following code tests a given string for forbidden characters. The forbidden characters are dependent on whether it is a 8.3 (short) or a long file name.


const
  { for short 8.3 file names }
  ShortForbiddenChars: set of Char = [';', '=', '+', '<', '>', '|',
  '"', '[', ']', '\', ''''];
  { for long file names }
  LongForbiddenChars: set of Char = ['<', '>', '|', '"', '\'];

function TestFilename(Filename: string; islong: Boolean): Boolean;
var
  I: integer;
begin
  Result := Filename <> '';
  if islong then
  begin
    for I := 1 to Length(Filename) do
      Result := Result and not (Filename[I] in LongForbiddenChars);
  end
  else
  begin
    for I := 1 to Length(Filename) do
      Result := Result and not (Filename[I] in ShortForbiddenChars);
  end;
end;

How to check if a social security number is valid ??

Problem/Question/Abstract:

How to check if a social security number is valid ??

note : only tested on the dutch social security numbers

Answer:

function CheckFiscaalNumber(Value: string): boolean;
var
  n1, n2, n3, n4, n5, n6, n7, n8, n9: integer;
  s1, s2, s3, s4, s5, s6, s7, s8: integer;
  totaal, rest: integer;
begin
  if StrToInt(Value) > 10000000 then
  begin
    if Length(Value) >= 8 then
    begin

      if Length(Value) = 8 then
      begin
        Value := '0' + Value;
      end;

      n1 := StrToInt(copy(Value, 1, 1));
      n2 := StrToInt(copy(Value, 2, 1));
      n3 := StrToInt(copy(Value, 3, 1));
      n4 := StrToInt(copy(Value, 4, 1));
      n5 := StrToInt(copy(Value, 5, 1));
      n6 := StrToInt(copy(Value, 6, 1));
      n7 := StrToInt(copy(Value, 7, 1));
      n8 := StrToInt(copy(Value, 8, 1));
      n9 := StrToInt(copy(Value, 9, 1));

      s1 := n1 * 9;
      s2 := n2 * 8;
      s3 := n3 * 7;
      s4 := n4 * 6;
      s5 := n5 * 5;
      s6 := n6 * 4;
      s7 := n7 * 3;
      s8 := n8 * 2;

      totaal := s1 + s2 + s3 + s4 + s5 + s6 + s7 + s8;
      rest := totaal mod 11;

      if rest <> n9 then
      begin
        Result := False;
      end
      else
      begin
        Result := True;
      end;
    end
    else
    begin
      Result := False;
    end;

  end
  else
  begin
    Result := False;
  end;

end;

How to get the handle of the edit box in the Internet Explorer

Problem/Question/Abstract:

I need to get the EditBox's handle(HWND) in IE. I can't do it, although I get the edit handle in other forms with the mousehook function.

Answer:

Solve 1:

Try the following:


var
  hndl: HWND;
  main: HWND;
begin
  main := FindWindow('IEFrame', nil);

  if main <> 0 then
  begin
    hndl := findwindowex(main, 0, 'Worker', nil);

    if hndl <> 0 then
    begin
      hndl := findwindowex(hndl, 0, 'ReBarWindow32', nil);

      if hndl <> 0 then
      begin
        hndl := findwindowex(hndl, 0, 'ComboBoxEx32', nil);

        if hndl <> 0 then
        begin
          hndl := findwindowex(hndl, 0, 'ComboBox', nil);

          if hndl <> 0 then
          begin
            hndl := findwindowex(hndl, 0, 'Edit', nil);


Solve 2:

Unfortunately, you will not be able to get the handle from one that is a child of Internet Explorer_Server, as IE renders that itself from the HTML (input type="text" ...)

Here's some code to get the handle of the AddressBar edit control:


unit Unit1;

interface

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

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

var
  Form1: TForm1;
  EditHandle: THandle;

implementation

{$R *.DFM}

function EnumIEChildProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
var
  tmpS: string;
  theClassName: string;
  theWinText: string;
begin
  Result := True;
  SetLength(theClassName, 256);
  GetClassName(AHandle, PChar(theClassName), 255);
  SetLength(theWinText, 256);
  GetWindowText(AHandle, PChar(theWinText), 255);
  tmpS := StrPas(PChar(theClassName));
  if theWinText <> EmptyStr then
    tmpS := tmpS + '"' + StrPas(PChar(theWinText)) + '"'
  else
    tmpS := tmpS + '""';
  if Pos('Edit', tmpS) > 0 then
  begin
    EditHandle := AHandle;
  end;
end;

function IEWindowEnumProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
{callback for EnumWindows.}
var
  theClassName: string;
  theWinText: string;
  tmpS: string;
begin
  Result := True;
  SetLength(theClassName, 256);
  GetClassName(AHandle, PChar(theClassName), 255);
  SetLength(theWinText, 256);
  GetWindowText(AHandle, PChar(theWinText), 255);
  tmpS := StrPas(PChar(theClassName));
  if theWinText <> EmptyStr then
    tmpS := tmpS + '"' + StrPas(PChar(theWinText)) + '"'
  else
    tmpS := tmpS + '""';
  if Pos('IEFrame', tmpS) > 0 then
  begin
    EnumChildWindows(AHandle, @EnumIEChildProc, longInt(0));
  end;
end;

procedure TForm1.FindIEEditHandle;
begin
  Screen.Cursor := crHourGlass;
  try
    EnumWindows(@IEWindowEnumProc, LongInt(0));
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FindIEEditHandle;
  if EditHandle > 0 then
    Label1.Caption := IntToStr(EditHandle)
  else
    label1.Caption := 'Not Found';
end;

end.

How to read a TMemoField into a string

Problem/Question/Abstract:

How to read a TMemoField into a string

Answer:

var
  stream: TBlobStream;
  theString: string;
begin
  stream := TBlobStream.Create(Table1.FieldByName('Comments') as TMemoField, bmRead);
  try
    SetLength(theString, stream.size);
    stream.Read(theString[1], stream.size);
  finally
    stream.Free;
  end;
end;

How to paint into another windows' caption bar

Problem/Question/Abstract:

How to paint into another windows' caption bar

Answer:

If you can get a handle to a Windows object, generally if it supports a WM_SETTEXT message (most windows do), then you can change the caption. The example below does just that:

procedure Form1.Button1Click(Sender: TObject);
begin
  WinExec('notepad.exe', SW_SHOWNORMAL);
end;

procedure Form1.Button2Click(Sender: TObject);
var
  hChild: HWND;
  strNewTitle: string;
begin
  hChild := FindWindow(nil, 'Untitled - Notepad');
  if (hChild <> NULL) then
  begin
    strNewTitle := ' Funny name ';
    SendMessage(hChild, WM_SETTEXT, 0, LPARAM(PChar(strNewTitle)));
  end;
end;

Note that this was written in D5 and the FindWindow(...) function can be a little ornery in some instances (like case sensitivity and precise text makeup, see example).

Adding a datetime part to a TDateTime type variable

Problem/Question/Abstract:

How to add a just a part of date/time (eg day, minute, or month) to a TDateTime type variable.

Answer:

I found VBScript's buildin function: DateAdd() is very handy. It allows you to specify which part-of-date you wish to add.

Here's the Object Pascal version. I changed the name to DateTimeAdd() to make it more descriptive -- emphasizing that it works for DateTime instead of just Date. The original function expects a plain char type argument to specify the date part. I replaced that one with an enumeration type, ensuring the passed argument is in correct form during compile time.

I'm not going to describe VBScript's DateAdd() further. Your knowledge about that function will help a bit, but know nothing about it is completely fine.

uses
  ..., SysUtils;

type
  TDateTimePart = (dtpHour, dtpMinute, dtpSecond, dtpMS, dtpDay, dtpMonth,
    dtpYear);

function DateTimeAdd(SrcDate: TDateTime; DatePart: TDateTimePart;
  DiffValue: Integer): TDateTime;

implementation

function DateTimeAdd(SrcDate: TDateTime; DatePart: TDateTimePart;
  DiffValue: Integer): TDateTime;
var
  m, d, y: Word;
begin
  case DatePart of
    dtpHour: { hour }
      Result := SrcDate + (DiffValue / 24);
    dtpMinute: { Minute }
      Result := SrcDate + (DiffValue / 1440);
    dtpSecond: { Second }
      Result := SrcDate + (DiffValue / 86400);
    dtpMS: { Millisecond }
      Result := SrcDate + (DiffValue / 86400000);
    dtpDay: { Day }
      Result := SrcDate + DiffValue;
    dtpMonth: { Month }
      Result := IncMonth(SrcDate, DiffValue);
  else { Year }
    begin
      DecodeDate(SrcDate, y, m, d);
      Result := Trunc(EncodeDate(y + DiffValue, m, d)) +
        Frac(SrcDate);
    end;
  end; {case}
end;

Sample:

var
  Date3MonthsAfterNow: TDateTime;
  Date2YearsAgo: TDateTime;
  Date11DaysAfterNow: TDateTime;
begin
  Date3MonthsAfterNow := DateTimeAdd(Now, dtpMonth, 3);
  Date2YearsAgo := DateTimeAdd(Now, dtpYear, -2); // negative is OK
  Date11DaysAfterNow := DateTimeAdd(Now, dtpDay, 11);
end;

Paint formatted text on the title bar of a TForm

Problem/Question/Abstract:

How to paint formatted text on the title bar of a TForm

Answer:

This source code allows you to write text everywhere on the form and also on the title bar. You can even rotate the text at a certain angle. Just keep in mind, that the code below only works with Truetype fonts.

{ ... }
private
{Private declarations}

procedure Check(var aMsg: TMessage); message WM_ACTIVATE;
public
  {Public declarations}
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure MyTextOut(form: TForm; txt: string; x, y, angle, fontsize: Integer;
  fontcolor: TColor;
  fontname: PChar; italic, underline: Boolean);
var
  H: HDC;
  l, myfont: Integer;
begin
  l := length(txt);
  H := GetWindowDC(Form.handle);
  SetTextColor(H, fontcolor);
  SetBkMode(H, Transparent);
  Myfont := CreateFont(fontsize, 0, angle * 10, 0, FW_SEMIBOLD, ord(italic),
    ord(underline), 0,
    DEFAULT_CHARSET, OUT_TT_PRECIS, $10, 2, 4, fontname);
  SelectObject(H, myfont);
  TextOut(H, x, y, pchar(txt), l);
  DeleteObject(myfont);
  ReleaseDC(Form.handle, H);
end;

{Paint text on title bar}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Caption := '';
end;

procedure DrawText;
begin
  MyTextout(Form1, 'This is italic', 30, 25, 0, 15, clYellow, 'Arial', true, false);
  MyTextout(Form1, 'This is underline', 125, 5, 0, 15, clYellow, 'Arial', false,
    true);
end;

procedure TForm1.Check(var aMsg: TMessage);
begin
  DrawText;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  DrawText;
end;

How to change the decimal point on a numerical keypad to a comma

Problem/Question/Abstract:

Is there a way to change the decimal point (.) on the numeric keypad to a comma (,) on the application level?

Answer:

You can use a handler for the Application.OnMessage event. Changing the decimal separator produced by numpad globally:

procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
begin
  case Msg.Message of
    WM_KEYDOWN, WM_KEYUP:
      if (Msg.wparam = VK_DECIMAL) and (Odd(GetKeyState(VK_NUMLOCK))) then
      begin
        Msg.wparam := 190; { for point, use 188 for comma }
        Msg.lparam := MakeLParam(LoWord(msg.lparam), (HiWord(Msg.lparam)
          and $FE00) + MapVirtualKey(Msg.wparam, 0));
      end;
  end;
end;

How to find files with wildcards

Problem/Question/Abstract:

How can I find files using wildcards? For example:

wildcards('c:\*.txt', 'c:\test.txt') = true
wildcards('*.c?g', '123.cfg') = true
wildcards('c*.doc', 'doc.doc') = false

Answer:

type
  PathStr = string[128]; { in Delphi 2/3: = string }
  NameStr = string[12]; { in Delphi 2/3: = string }
  ExtStr = string[3]; { in Delphi 2/3: = string }

{$V-}
  { in Delphi 2/ 3 to switch off "strict var-strings" }

function WildComp(FileWild, FileIs: PathStr): boolean;
var
  NameW, NameI: NameStr;
  ExtW, ExtI: ExtStr;
  c: Byte;

  function WComp(var WildS, IstS: NameStr): boolean;
  var
    i, j, l, p: Byte;
  begin
    i := 1;
    j := 1;
    while (i <= length(WildS)) do
    begin
      if WildS[i] = '*' then
      begin
        if i = length(WildS) then
        begin
          WComp := true;
          exit
        end
        else
        begin
          { we need to synchronize }
          l := i + 1;
          while (l < length(WildS)) and (WildS[l + 1] <> '*') do
            inc(l);
          p := pos(copy(WildS, i + 1, l - i), IstS);
          if p > 0 then
          begin
            j := p - 1;
          end
          else
          begin
            WComp := false;
            exit;
          end;
        end;
      end
      else if (WildS[i] <> '?') and ((length(IstS) < i) or (WildS[i] <> IstS[j])) then
      begin
        WComp := false;
        exit
      end;
      inc(i);
      inc(j);
    end;
    WComp := (j > length(IstS));
  end;

begin
  c := pos('.', FileWild);
  if c = 0 then
  begin { automatically append .* }
    NameW := FileWild;
    ExtW := '*';
  end
  else
  begin
    NameW := copy(FileWild, 1, c - 1);
    ExtW := copy(FileWild, c + 1, 255);
  end;
  c := pos('.', FileIs);
  if c = 0 then
    c := length(FileIs) + 1;
  NameI := copy(FileIs, 1, c - 1);
  ExtI := copy(FileIs, c + 1, 255);
  WildComp := WComp(NameW, NameI) and WComp(ExtW, ExtI);
end;

{ Example }
begin
  if WildComp('a*.bmp', 'auto.bmp') then
    ShowMessage('OK 1');
  if not WildComp('a*x.bmp', 'auto.bmp') then
    ShowMessage('OK 2');
  if WildComp('a*o.bmp', 'auto.bmp') then
    ShowMessage('OK 3');
  if not WildComp('a*tu.bmp', 'auto.bmp') then
    ShowMessage('OK 4');
end;

end.

How to check when the user last clicked on the program's interface

Problem/Question/Abstract:

Is there a way to find out when the user last clicked on a program's interface? It is some sort of like idle time but the idle time for this specific program.

Answer:

From inside the application it is fairly easy. You need three pieces of equipment here:

A "Time of last activity" variable, field of your main form

FLastActive: TDateTime;


A timer that regularly checks the FLastActive variable against the current time. Set it to an interval of, say 60000, and set its Active property to true at design-time. The OnTimer event handler would be something like this (timeout after 15 minutes):

if (FLastActive + EncodeTime(0, 15, 0, 0)) < Now then
  Close;


A handler for the Application.OnMessage event that updates the FLastActive variable on each key or mouse message. The handler would do something like this:

case msg.Message of
  WM_KEYFIRST..WM_KEYLAST, WM_MOUSEFIRST..WM_MOUSELAST:
    FLastActive := Now;
end;

Save a screen shot to a JPEG file

Problem/Question/Abstract:

How can I write a screen capture not to a bitmap file but to a JPEG file?

Answer:

procedure ScreenShot(x: integer; y: integer; Width: integer; Height: integer; bm: TBitmap);
var
  dc: HDC;
  lpPal: PLOGPALETTE;
begin
  {test width and height}
  if ((Width = 0) or (Height = 0)) then
  begin
    exit;
  end;
  bm.Width := Width;
  bm.Height := Height;
  {get the screen dc}
  dc := GetDc(0);
  if (dc = 0) then
  begin
    exit;
  end;
  {do we have a palette device?}
  if (GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE) then
  begin
    {allocate memory for a logical palette}
    GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    {zero it out to be neat}
    FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
    {fill in the palette version}
    lpPal^.palVersion := $300;
    {grab the system palette entries}
    lpPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, lpPal^.palPalEntry);
    if (lpPal^.PalNumEntries < > 0) then
    begin
      {create the palette}
      bm.Palette := CreatePalette(lpPal^);
    end;
    FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
  end;
  {copy from the screen to the bitmap}
  BitBlt(bm.Canvas.Handle, 0, 0, Width, Height, Dc, x, y, SRCCOPY);
  {release the screen dc}
  ReleaseDc(0, dc);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  bm: TBitmap;
  jp: TJPEGImage;
begin
  bm := TBitmap.Create;
  ScreenShot(0, 0, Screen.Width, Screen.Height, bm);
  jp := TJPEGImage.Create;
  jp.Assign(bm);
  bm.free;
  jp.SaveToFile('Test.jpg');
  jp.Free;
end;

Reading information from an AVI file

Problem/Question/Abstract:

How to read information from an AVI file

Answer:

First, put a memo, button and a open dialog on an empty form. Then use the
following code to show the information of a avi file.

procedure TForm1.ReadAviInfo(FileName: string);
var
  iFileHandle: Integer; // File handle

  // Needed for positioning in the avi file
  Aviheadersize: integer;
  Vheadersize: integer;
  Aviheaderstart: integer;
  Vheaderstart: integer;
  Aheaderstart: integer;
  Astrhsize: integer;

  // Temporary values
  TempTest: string[5];
  TempSize: Integer;
  TempVcodec: string[5];
  TempAcodec: integer;
  TempMicrosec: integer;
  TempLengthInFrames: integer;
  TempAchannels: integer;
  TempAsamplerate: integer;
  TempAbitrate: integer;

  // Final values
  Size: double;
  Length: string;
  Vcodec: string;
  Vbitrate: double;
  VWidth: integer;
  VHeight: integer;
  Fps: double;

  LengthInSec: double;
  Acodec: string;
  Abitrate: string;
begin
  // Open the file
  iFileHandle := FileOpen(FileName, fmOpenRead);

  // Test to see if file is AVI
  FileSeek(iFileHandle, 7, 0);
  FileRead(iFileHandle, TempTest, 5);
  if copy(TempTest, 0, 4) <> 'AVI ' then
  begin
    MessageDlg('Could not open ' + FileName + ' because it is not a valid video file', mtError, [mbOk], 0);
    Exit;
  end;

  // File size
  FileSeek(iFileHandle, 4, 0);
  FileRead(iFileHandle, TempSize, 4);

  // Avi header size (needed to locate the audio part)
  FileSeek(iFileHandle, 28, 0);
  FileRead(iFileHandle, Aviheadersize, 4);

  // Avi header start (needed to locate the video part)
  Aviheaderstart := 32;

  // Microseconds (1000000 / TempMicrosec = fps)
  FileSeek(iFileHandle, Aviheaderstart, 0);
  FileRead(iFileHandle, TempMicrosec, 4);

  // Length of movie in frames
  FileSeek(iFileHandle, Aviheaderstart + 16, 0);
  FileRead(iFileHandle, TempLengthInFrames, 4);

  // Width
  FileSeek(iFileHandle, Aviheaderstart + 32, 0);
  FileRead(iFileHandle, VWidth, 4);

  // Height
  FileSeek(iFileHandle, Aviheaderstart + 36, 0);
  FileRead(iFileHandle, VHeight, 4);

  FileSeek(iFileHandle, Aviheaderstart + Aviheadersize + 4, 0);
  FileRead(iFileHandle, Vheadersize, 4);

  Vheaderstart := Aviheaderstart + Aviheadersize + 20;

  // Video codec
  FileSeek(iFileHandle, Vheaderstart + 3, 0);
  FileRead(iFileHandle, TempVCodec, 5);

  Aheaderstart := Vheaderstart + Vheadersize + 8;

  FileSeek(iFileHandle, Aheaderstart - 4, 0);
  FileRead(iFileHandle, Astrhsize, 5);

  // Audio codec
  FileSeek(iFileHandle, Aheaderstart + Astrhsize + 8, 0);
  FileRead(iFileHandle, TempACodec, 2);

  // Audio channels (1 = mono, 2 = stereo)
  FileSeek(iFileHandle, Aheaderstart + Astrhsize + 10, 0);
  FileRead(iFileHandle, TempAchannels, 2);

  // Audio samplerate
  FileSeek(iFileHandle, Aheaderstart + Astrhsize + 12, 0);
  FileRead(iFileHandle, TempAsamplerate, 4);

  // Audio bitrate
  FileSeek(iFileHandle, Aheaderstart + Astrhsize + 16, 0);
  FileRead(iFileHandle, TempAbitrate, 4);

  // Close the file
  FileClose(iFileHandle);

  // Analyse the video codec (more can be added)
  Vcodec := copy(TempVcodec, 0, 4);
  if Vcodec = 'div2' then
    Vcodec := 'MS MPEG4 v2'
  else if Vcodec = 'DIV2' then
    Vcodec := 'MS MPEG4 v2'
  else if Vcodec = 'div3' then
    Vcodec := 'DivX;-) MPEG4 v3'
  else if Vcodec = 'DIV3' then
    Vcodec := 'DivX;-) MPEG4 v3'
  else if Vcodec = 'div4' then
    Vcodec := 'DivX;-) MPEG4 v4'
  else if Vcodec = 'DIV4' then
    Vcodec := 'DivX;-) MPEG4 v4'
  else if Vcodec = 'div5' then
    Vcodec := 'DivX;-) MPEG4 v5'
  else if Vcodec = 'DIV5' then
    Vcodec := 'DivX;-) MPEG4 v5'
  else if Vcodec = 'divx' then
    Vcodec := 'DivX 4'
  else if Vcodec = 'mp43' then
    Vcodec := 'Microcrap MPEG4 v3';

  // Analyse the audio codec (more can be added)
  case TempAcodec of
    0: Acodec := 'PCM';
    1: Acodec := 'PCM';
    85: Acodec := 'MPEG Layer 3';
    353: Acodec := 'DivX;-) Audio';
    8192: Acodec := 'AC3-Digital';
  else
    Acodec := 'Unknown (' + IntToStr(TempAcodec) + ')';
  end;

  case (Trunc(TempAbitrate / 1024 * 8)) of
    246..260: Abitrate := '128 Kbit/s';
    216..228: Abitrate := '128 Kbit/s';
    187..196: Abitrate := '128 Kbit/s';
    156..164: Abitrate := '128 Kbit/s';
    124..132: Abitrate := '128 Kbit/s';
    108..116: Abitrate := '128 Kbit/s';
    92..100: Abitrate := '128 Kbit/s';
    60..68: Abitrate := '128 Kbit/s';
  else
    Abitrate := FormatFloat('# Kbit/s', TempAbitrate / 1024 * 8);
  end;

  // Some final calculations
  Size := TempSize / 1024 / 1024;
  Fps := 1000000 / TempMicrosec; // FPS
  LengthInSec := TempLengthInFrames / fps; // Length in seconds
  Length := FormatFloat('# min', Int(LengthInSec / 60)) + FormatFloat(' # sec',
    Round(LengthInSec - (Int(LengthInSec / 60) * 60)));
  Vbitrate := (TempSize / LengthInSec - TempABitrate) / 1024 * 8;

  // Output information to memo field
  Memo1.Lines.Add('AVI INFORMATION');
  Memo1.lines.Add('Size: ' + FormatFloat('#.## MB', Size));
  Memo1.Lines.Add('Length: ' + Length);
  Memo1.Lines.Add('');
  Memo1.Lines.Add('VIDEO INFORMATION');
  Memo1.Lines.Add('Codec: ' + Vcodec);
  Memo1.Lines.Add('Bitrate: ' + FormatFloat('# Kbit/s', Vbitrate));
  Memo1.lines.Add('Width: ' + IntToStr(VWidth) + ' px');
  Memo1.lines.Add('Height: ' + IntToStr(VHeight) + ' px');
  Memo1.Lines.Add('FPS: ' + FormatFloat('#.##', fps));
  Memo1.Lines.Add('');
  Memo1.Lines.Add('AUDIO INFORMATION');
  Memo1.Lines.Add('Codec: ' + Acodec);
  Memo1.Lines.Add('Bitrate: ' + Abitrate);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Filter := 'AVI files (*.avi)|*.avi';
  if OpenDialog1.Execute then
  begin
    Memo1.Clear;
    ReadAviInfo(OpenDialog1.FileName);
  end;
end;

Smart threads with a central management

Problem/Question/Abstract:

Ever wanted to fire up some threads in your application, let them do some time consuming stuff and then report the results to the user? This caused some synchronisation trouble, didn't it? Shutting down your app while threads where still running, updating the user interface...
Here is a unit that will give a good bases to avoid all kinds of multi threading trouble.

Answer:

{ -----------------------------------------------------------------------
  Newer version and test bench can be found here:
  http://codecentral.borland.com/codecentral/ccweb.exe/listing?id=17700
  -----------------------------------------------------------------------

  Smart Thread Lib
  Version 1.01
  Copyright (c) 2002 by DelphiFactory Netherlands BV

  What is it:
  Provides an easy way to use threads.

  Usage:
  Create your threads as TSmartThreads and manage them
  using the SmartThreadManager global object.

  For more information about threads in delphi:
  http://www.pergolesi.demon.co.uk/prog/threads/ToC.html

  For example on how to use this unit for with a Indy blocking
  socket TCP/IP client:
   "SmartThreadLib example: Using blocking Indy sockets in a thread" article
}

unit SmartThreadLib;

{ Defining the DefaultMessageHandler causes the messages send
  by the threads to be displayed on screen if no OnMessage handler
  is assigned. This is only for debugging purposes (as GUI routines should
  not be located in this unit). }
{$DEFINE DefaultMessageHandler}

interface

uses
  SysUtils, Classes, Contnrs
{$IFDEF DefaultMessageHandler}
  , QDialogs
{$ENDIF}
  ;

resourcestring
  SForcedStop = 'Thread ''%s'' forced to stop';

  { EThreadForcedShutdown exception will be raised inside a thread when
    it has to stop running. }
type
  EThreadForcedShutdown = class(Exception);

  { The ThreadMessageEvent is called by a smart thread but within the
    context of the main thread and provides the ability to easily show messages
    to the user. }
type
  TThreadMessageEvent = procedure(Sender: TObject; const AMessage: string) of object;

  { The SmartThread.
    Usage:
      1. Create a descendent class.
      2. Override the SmartExecute.
      3. Call Check from within SmartExecute on a regular base. This
         routine will raise an EThreadForcedShutdown exception if the thread
         has to stop. The exception is handled by this base class, you do
         not need to handle it.

    Additional tips:
      - You can use the Msg() procedure to show messages to the user without
        having to worry about synchronisation problems.
      - You can override GetMustStop() to add additional checks that could
        cause a thread to do a forced shutdown.
      - SmartExecute is started directly after calling Create()
      - The thread is FreeOnTerminate.
      - SmartThreads are based on the idea that threads are independant. You
        should not keep a pointer to the new thread, because you can never know
        if this pointer is still valid.
        Instead let your threads communicate using a global object. As an
        example se the SmartThreadManager.
  }
type
  TSmartThread = class(TThread)
  private
    FMsg: string;
    procedure DoMessage;
  protected
    function GetMustStop: Boolean; virtual;
    procedure Msg(const Msg: string); virtual;
    procedure Check;

    procedure Execute; override;
    procedure SmartExecute; virtual;
  public
    constructor Create; virtual;
    property MustStop: Boolean read GetMustStop;
  end;

  { The SmartThreadManager: Global object that manages all TSmartThread's.

    The SmartThreads register themselfs at this manager before
    executing, and unregister just before destroying itself.

    - SmartThreads are based on the idea that threads are independant. You
    should not keep a pointer to the new thread, because you can never know
    if this pointer is still valid.  Instead let your threads communicate
    using a global object. The manager provides an event called OnMessage.
    The threads can trigger this event by calling their Msg() method. The
    OnMessage event runs in the context of the main thread. So screen updates
    can be performed. The Sender parameter is the thread which has send the
    message. This thread is guarantied to exist and is in suspended mode during
    the execution of the eventhandler.
    (If 'DefaultMessageHandler' is defined during compilation, the message will
    be displayed automaticly when no handler is assigned.)

    - Set ShutDown to True to shutdown all the smart threads.

    - ThreadCount returns the number of currently running smart threads

    - All threads are terminated automaticaly when the manager is destroyed.
      The manager is created and destroyed by the initialization and
      finalization section in this unit.
  }
type
  TSmartThreadManager = class
  private
    FThreadListSync: TMultiReadExclusiveWriteSynchronizer;
    FShutDownSync: TMultiReadExclusiveWriteSynchronizer;
    FThreadList: TObjectList;
    FShutDown: Boolean;
    FOnMessage: TThreadMessageEvent;
    function GetShutDown: Boolean;
    procedure SetShutDown(const Value: Boolean);
    function GetThreadCount: Integer;
  protected
    procedure RegisterThread(AThread: TSmartThread);
    procedure UnregisterThread(AThread: TSmartThread);
    procedure DoMessage(Sender: TObject; AMessage: string);
  public
    constructor Create;
    destructor Destroy; override;

    procedure LimitThreadCount(Max: Integer);

    property ThreadCount: Integer read GetThreadCount;
    property Shutdown: Boolean read GetShutDown write SetShutDown;
    property OnMessage: TThreadMessageEvent read FOnMessage write FOnMessage;
  end;

var
  SmartThreadManager: TSmartThreadManager;

implementation

{ TSmartThread }

procedure TSmartThread.Check;
begin
  // raise exception when the thread needs to stop
  if MustStop then
    raise EThreadForcedShutdown.CreateFmt(SForcedStop, [Self.ClassName]);
end;

constructor TSmartThread.Create;
begin
  // create in suspended mode
  inherited Create(True);
  // init
  FreeOnTerminate := True;

  // register at the manager
  SmartThreadManager.RegisterThread(Self);

  // run the thread
  Suspended := False;
end;

procedure TSmartThread.DoMessage;
{ Call this method using Synchronize(DoMessage)
  to make sure that we are running in the context of the main thread }
begin
  // Notify the manager about the message
  SmartThreadManager.DoMessage(Self, FMsg);
end;

procedure TSmartThread.Execute;
begin
  try
    try
      // Perform code to be implemented by descendant class
      SmartExecute;
    except
      // ignore forced shutdown exceptions
      on E: EThreadForcedShutdown do {nothing}
        ;
    end;
  finally
    // unregister at the manager
    SmartThreadManager.UnregisterThread(Self);
  end;
  // After unregistering the smart thread should shutdown
  // as fast as possible and do not perform any more tasks.
end;

function TSmartThread.GetMustStop: Boolean;
begin
  // We must stop if the thread is marked as terminated
  //   or if the manager wants to shutdown
  Result := Terminated or SmartThreadManager.Shutdown;
end;

procedure TSmartThread.Msg(const Msg: string);
begin
  // save message for later use by DoMessage
  FMsg := Msg;
  // call the DoMessage in the context of the main thread
  Synchronize(DoMessage);
end;

procedure TSmartThread.SmartExecute;
begin
  // do nothing, method can be implemented by descendant
end;

{ TSmartThreadManager }

constructor TSmartThreadManager.Create;
begin
  inherited Create;
  // init
  FShutdownSync := TMultiReadExclusiveWriteSynchronizer.Create;
  FThreadListSync := TMultiReadExclusiveWriteSynchronizer.Create;
  FThreadList := TObjectList.Create(False);
end;

destructor TSmartThreadManager.Destroy;
begin
  // manager is shutting down - cause al threads to stop
  SetShutDown(True);

  // wait for all threads to have stopped
  LimitThreadCount(0);

  // now we can cleanup
  FThreadList.Free;
  FThreadListSync.Free;
  FShutDownSync.Free;

  inherited Destroy;
end;

procedure TSmartThreadManager.DoMessage(Sender: TObject; AMessage: string);
const
  SMsg = '%s message: ''%s''';
begin
  // Call eventhandler
  if Assigned(FOnMessage) then
    FOnMessage(Sender, AMessage)
{$IFDEF DefaultMessageHandler}
  else // if there is no eventhandler, display the message on screen
    ShowMessage(Format(SMsg, [Sender.ClassName, AMessage]));
{$ENDIF}
end;

function TSmartThreadManager.GetShutDown: Boolean;
{ ThreadSafe
  Returns the Shutdown flag
}
begin
  FShutdownSync.BeginRead;
  try
    Result := FShutDown;
  finally
    FShutdownSync.EndRead;
  end;
end;

function TSmartThreadManager.GetThreadCount: Integer;
{ ThreadSafe
  Returns the number of running smart threads
}
begin
  FThreadListSync.BeginRead;
  try
    Result := FThreadList.Count;
  finally
    FThreadListSync.EndRead;
  end;
end;

procedure TSmartThreadManager.LimitThreadCount(Max: Integer);
{ Should only be called in the context of the main thread.

  Returns until the number of runnning smart threads is
  equal or lower then the Max parameter.
}
begin
  while GetThreadCount > Max do
    if not CheckSynchronize then
      Sleep(100);
end;

procedure TSmartThreadManager.RegisterThread(AThread: TSmartThread);
{ Thread safe
  Is called by the TSmartThread.Create constructor to register
  a new smart thread.
}
begin
  FThreadListSync.BeginWrite;
  try
    if FThreadList.IndexOf(AThread) = -1 then
      FThreadList.Add(AThread);
  finally
    FThreadListSync.EndWrite;
  end;
end;

procedure TSmartThreadManager.SetShutDown(const Value: Boolean);
{ Thread Safe
  Set the shutdown flag.
}
begin
  // make sure this is an different value
  if Value <> GetShutDown then
  begin
    FShutdownSync.BeginWrite;
    try
      // set new value
      FShutDown := Value;
    finally
      FShutdownSync.EndWrite;
    end;
  end;
end;

procedure TSmartThreadManager.UnregisterThread(AThread: TSmartThread);
{ Thread Safe
  Called by TSmartThread.Execute after the TSmartThread.SmartExecute
  has finished (or an exception was raised). it unregisters the thread.
}
begin
  FThreadListSync.BeginWrite;
  try
    FThreadList.Remove(AThread)
  finally
    FThreadListSync.EndWrite;
  end;
end;

initialization
  // fire up the manager
  SmartThreadManager := TSmartThreadManager.Create;
finalization
  // going down
  SmartThreadManager.Free;
end.