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.