How to use the Wininit.ini to delete files on startup

Problem/Question/Abstract:

Can anyone tell me how to delete several files using wininit.ini please?I've seen an example somewhere that included the following :

[Rename]
NULL=C:\temp\readme.txt

Using the regular inifile calls, I cant use the above method for deleting several files because each WriteString would overwrite previous "NULL=" entries. I'm unable to find any info about using wininit.ini anywhere, there might be a [delete] section for all I know.

Answer:

This will do the job:

procedure DeleteAtReboot(FileList: TStringList);
var
  SList: TStringList;
  szContents: string;
  i, SectionFoundIndex: Integer;
  WinDir: array[0..MAX_PATH] of char;
  WinFile: string;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    {Use MoveFileEx}
    for i := 0 to FileList.count - 1 do
      MoveFileEx(PChar(FileList[i]), nil, MOVEFILE_DELAY_UNTIL_REBOOT);
  end
  else
  begin
    GetWindowsDirectory(WinDir, MAX_PATH);
    WinFile := IncludeTrailingBackslash(WinDir) + 'Wininit.ini';
    SList := TStringList.Create;
    try
      SectionFoundIndex := -1;
      {Load it if it exists}
      if FileExists(WinFile) then
        SList.LoadFromFile(WinFile);
      for i := 0 to SList.Count - 1 do
      begin
        szContents := uppercase(SList[i]);
        if UpperCase(SList[i]) = '[RENAME]' then
        begin
          SectionFoundIndex := i;
          break;
        end;
      end;
      {Rename Section doesn't exist...}
      if SectionFoundIndex = -1 then
        SectionFoundIndex := SList.Add('[Rename]');
      {Now Add our Files}
      for i := 0 to FileList.count - 1 do
        SList.Insert(SectionFoundIndex + 1, 'NUL=' + FileList[i]);
      SList.SaveToFile(WinFile);
    finally
      SList.Free;
    end;
  end;
end;

How to move the active record in a table to a certain position on a TDBGrid

Problem/Question/Abstract:

Does anyone know of a way to move the active record in a table to a certain position on a TDBGrid (i.e. the centre of a grid, top or bottom, or row number)

Answer:

This is a method that I use in a subclassed DBGrid. You can save the original row with:

OldRow := Row - TopRow;

and move with:

MoveToRow(OldRow);


procedure TMyDBGrid.MoveToRow(NewRow: Integer);
{Scrolls the visible records so that the current record is shown on the NewRow position (if possible)}
var
  Mark: TBookmarkStr;
begin
  Mark := DataLink.DataSet.Bookmark;
  {Set the current row to NewRow. This also moves the record pointer}
  DataLink.ActiveRecord := NewRow;
  {Goto the original record}
  DbiSetToBookmark(TDBDataSet(DataLink.DataSet).Handle, Pointer(Mark));
  {Force a reread of the record buffer with the current settings}
  DataLink.DataSet.Resync([rmExact]);
end;


Row, TopRow and DataLink are protected properties of DBGrid, so they can only be used
in (or through) a subclass.

How to autoscale a TBitmap while keeping the aspect ratio

Problem/Question/Abstract:

How to autoscale a TBitmap while keeping the aspect ratio

Answer:

Explanation on explicit demand!

procedure TForm1.Image1Paint(Sender: TObject);
var
  Bitmap: TBitmap;
  Breite, Hoehe: Real;
  links, rechts, oben, unten: integer;
  Feld: TRect;
begin
  Image1.Canvas.Pen.Color := Form1.Color;
  Image1.Canvas.Brush.Color := Form1.Color;
  Feld.Left := 0;
  Feld.Right := Image1.Width;
  Feld.Top := 0;
  Feld.Bottom := Image1.Height;
  Image1.Canvas.Rectangle(Feld);
  Application.ProcessMessages;
  Bitmap := TBitmap.Create;
  Bitmap.PixelFormat := pf24bit;
  Bitmap.LoadFromFile('C:\Bild.bmp');
  Breite := Bitmap.Width / Image1.Width;
  Hoehe := Bitmap.Height / Image1.Height;
  if Breite >= Hoehe then
  begin
    links := 0;
    rechts := Image1.Width;
    oben := (Image1.Height - Trunc(Bitmap.Height / Breite)) div 2;
    unten := oben + Trunc(Bitmap.Height / Breite);
  end
  else
  begin
    oben := 0;
    unten := Image1.Height;
    links := (Image1.Width - Trunc(Bitmap.Width / Hoehe)) div 2;
    rechts := links + Trunc(Bitmap.Width / Hoehe)
  end;
  Feld.Left := links;
  Feld.Right := rechts;
  Feld.Top := oben;
  Feld.Bottom := unten;
  Image1.Canvas.StretchDraw(Feld, Bitmap);
  Bitmap.Free;
end;

Fade out a bitmap

Problem/Question/Abstract:

Fade out a bitmap

Answer:

Put a TImage and load a bitmap of 24 bits  or 32 bits, put a TButton on the form and this code in its OnClick event

procedure TForm1.Button1Click(Sender: TObject);
  procedure FadeOut(const BMP: TImage; Pause: integer);
  var
    BytesPorScan: integer;
    w, h: integer;
    p: pByteArray;
    counter: integer;
  begin
    { This only works with 24 or 32 bits bitmaps }

    if not (BMP.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then
      raise exception.create('Error, bitmap format not supported.');

    try
      BytesPorScan := Abs(Integer(BMP.Picture.Bitmap.ScanLine[1]) -
        Integer(BMP.Picture.Bitmap.ScanLine[0]));
    except
      raise exception.create('Error');
    end;

    { Decrease the RGB components of each single pixel }
    for counter := 1 to 256 do
    begin
      for h := 0 to BMP.Picture.Bitmap.Height - 1 do
      begin
        P := BMP.Picture.Bitmap.ScanLine[h];
        for w := 0 to BytesPorScan - 1 do
          if P^[w] > 0 then
            P^[w] := P^[w] - 1;
      end;
      Sleep(Pause);
      BMP.Refresh;
    end;
  end; {procedure FadeOut}

begin
  FadeOut(Image1, 5);
end;

Add an item to the menu in Word

Problem/Question/Abstract:

How to add an item to the menu in Word

Answer:

{ ... }
var
  CBar: CommandBar;
  MenuItem: OleVariant;
  { ... }

{ Add an item to the File menu }
CBar := Word.CommandBars['File'];
MenuItem := CBar.Controls.Add(msoControlButton, EmptyParam, EmptyParam,
  EmptyParam, True) as CommandBarButton;
MenuItem.Caption := 'NewMenuItem';
MenuItem.DescriptionText := 'Does nothing';
{Note that a VB macro with the right name must exist before you assign it to the item!}
MenuItem.OnAction := 'VBMacroName';
{ ... }

Move a form without a caption bar

Problem/Question/Abstract:

I have a panel that acts as a custom title bar, i.e. the window should be dragged by clicking inside this panel. In this case WM_NCHITTEST is not posted to TForm when the mouse pointer is over TPanel.

Answer:

Solve 1:

Basically you intercept the mouse-down and convert it into the equivalent of choosing "Move" from the System menu. You can hook the main form and any container-objects such as panels to the same handler.

procedure TMainForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button <> mbLeft then
    Exit;
  if Shift <> [ssLeft] then
    Exit;
  ReleaseCapture;
  Perform(WM_SYSCOMMAND, SC_MOVE + 2, Integer(PointToSmallPoint(Point(X, Y))));
end;


Solve 2:

var
  OldX, OldY: Integer;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  OldX := X;
  OldY := Y;
end;

procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then
    Form1.SetBounds(Left + (X - OldX), Top + (Y - OldY), Width, Height);
end;

Locate on a non-indexed field in a TTable

Problem/Question/Abstract:

How to locate on a non-indexed field in a TTable

Answer:

The following function can be added to your to your unit and called as follows:

Locate(Table1, Table1LName, 'Beman');

Table1 is your table component, Table1LName is TField you've add with the fields editor (double click on the table component) and 'Beman' is the name you want to find.

Locate will find SValue in a non-indexed table

function Locate(const oTable: TTable; const oField: TField;
  const sValue: string): Boolean;
var

  bmPos: TBookMark;
  bFound: Boolean;
begin
  Locate := False;
  bFound := False;
  if not oTable.Active then
    Exit;
  if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then
    Exit;
  bmPos := oTable.GetBookMark;
  with oTable do
  begin
    DisableControls;
    First;
    while not EOF do
      if oField.AsString = sValue then
      begin
        Locate := True;
        bFound := True;
        Break;
      end
      else
        Next;
  end;
  if (not bFound) then
    oTable.GotoBookMark(bmPos);
  oTable.FreeBookMark(bmPos);
  oTable.EnableControls;
end;

Combobox with colors

Problem/Question/Abstract:

Combobox with colors

Answer:

It is quite easy to create a combobox that shows a list of colors. You need to set the property "Style" to "csOwnerDrawFixed". This causes a call of "OnDrawItem" for each item in your combobox. The DrawItem routine draws a color bar..


// in FormCreate:
with ComboBox1.Items do
begin
  Add(IntToStr(clRed));
  Add(IntToStr(clFuchsia));
  Add(IntToStr(clBlue));
  Add(IntToStr(clGreen));
  Add(IntToStr(clYellow));
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  with Control as TComboBox, Canvas do
  begin
    // fill the rectangle first with white
    Brush.Color := clWhite;
    FillRect(Rect);
    // then reduce it and fill it with the color
    InflateRect(Rect, -2, -2);
    Brush.Color := StrToInt(Items[Index]);
    FillRect(Rect);
  end;
end;

Compact an Access database

Problem/Question/Abstract:

Using D6 Pro, Access XP and Jet 4.0 Sp6 - how can I compact Access files?

Answer:

This does it:

procedure TMainForm.ActionCompactAccessDBExecute(Sender: TObject);
var
  JetEngine: Variant;
  TempName: string;
  aAccess: string;
  stAccessDB: string;
  SaveCursor: TCursor;
begin
  stAccessDB := 'Provider = Microsoft.Jet.OLEDB.4.0;' +
    'Data Source = %s;Jet OLEDB: Engine type = ';
  stAccessDB := stAccessDB + '5'; {5 for Access 2000 and 4 for Access 97}
  OpenDialog1.InitialDir := oSoftConfig.ApplicationPath + 'Data\';
  OpenDialog1.Filter := 'MS Access (r) (*.mdb)|*.mdb';
  if OpenDialog1.execute and (uppercase(ExtractFileExt
    (OpenDialog1.FileName)) = '.MDB') then
  begin
    if MessageDlg('This process can take several minutes. Please wait till the end ' +
      #13 + #10 + 'of it. Do you want to proceed? Press No to exit.', mtInformation,
      [mbYes, mbNo], 0) = mrNo then
      exit;
    SaveCursor := screen.cursor;
    screen.cursor := crHourGlass;
    aAccess := OpenDialog1.FileName;
    TempName := ChangeFileExt(aAccess, '.$$$');
    DeleteFile(PChar(TempName));
    JetEngine := CreateOleObject('JRO.JetEngine');
    try
      JetEngine.CompactDatabase(Format(stAccessDB, [aAccess]),
        Format(stAccessDB, [TempName]));
      DeleteFile(PChar(aAccess));
      RenameFile(TempName, aAccess);
    finally
      JetEngine := Unassigned;
      screen.cursor := SaveCursor;
    end;
  end;
end;

Important Notes:
Include the JRO_TLB unit in your uses clause.
Nobody should use or open the database during compacting.
If the compiler gives you an error on the JRO_TLB unit follow these steps:
Using the Delphi IDE go to Project &#8211; Import Type Library.
Scroll down until you reach &#8220;Microsoft Jet and Replication Objects 2.1 Library&#8221;.
Click on Install button.
Recompile a gain.

How to make a TCollectionItem contain a TCollection

Problem/Question/Abstract:

I would like to create a component that contains a TCollection with TCollectionItems. Then I want to contain another TCollection with TCollectionItems within the TCollectionItems. I am trying to create a collection of sections, which would contain a collection of items for each section.

Answer:

It's not difficult to implement such functionality. One thing you need to care about is the valid Owner for your collections, presumably, the main control would be the best choice. Below is an example of such a component:


{ ... }
type
  TYourCollectionItem = class;
  TYourCollection = class;
  TColControl = class;

  TYourCollectionItem = class(TCollectionItem)
  protected
    FFirstString: string;
    FChildCollection: TYourCollection;
    procedure SetIndex(Value: Integer); override;
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property FirstString: string read FFirstString write FFirstString;
    property ChildCollection: TYourCollection read FChildCollection write
      FChildCollection;
  end;

  TYourCollection = class(TOwnedCollection)
  protected
    function GetItem(Index: Integer): TYourCollectionItem;
    procedure SetItem(Index: Integer; Value: TYourCollectionItem);
  public
    constructor Create(AOwner: TPersistent);
    property Items[Index: Integer]: TYourCollectionItem read GetItem write SetItem;
  end;

  TColControl = class(TComponent)
  protected
    FCollection: TYourCollection;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Collection: TYourCollection read FCollection write FCollection;
  end;

  { ... }

constructor TYourCollectionItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FChildCollection := TYourCollection.Create(Collection.Owner);
end;

destructor TYourCollectionItem.Destroy;
begin
  FChildCollection.Free;
  inherited Destroy;
end;

procedure TYourCollectionItem.SetIndex(Value: Integer);
begin
  inherited SetIndex(Value);
  ShowMessage(IntToStr(Value));
end;

function TYourCollectionItem.GetDisplayName: string;
begin
  Result := FFirstString;
end;

procedure TYourCollectionItem.Assign(Source: TPersistent);
begin
  FFirstString := TYourCollectionItem(Source).FFirstString;
  FChildCollection.Assign(TYourCollectionItem(Source).ChildCollection);
end;

constructor TYourCollection.Create(AOwner: TPersistent);
begin
  inherited Create(AOwner, TYourCollectionItem);
end;

function TYourCollection.GetItem(Index: Integer): TYourCollectionItem;
begin
  Result := TYourCollectionItem(inherited GetItem(Index));
end;

procedure TYourCollection.SetItem(Index: Integer; Value: TYourCollectionItem);
begin
  inherited SetItem(Index, Value);
end;

constructor TColControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCollection := TYourCollection.Create(Self);
end;

destructor TColControl.Destroy;
begin
  FCollection.Free;
  FCollection := nil;
  inherited Destroy;
end;

How to detect if a CD has been inserted or removed into/ from a drive

Problem/Question/Abstract:

How to detect if a CD has been inserted or removed into/ from a drive

Answer:

{ ... }
type
  TForm1 = class(TForm)
  private
    { private declarations }
    procedure WMDeviceChange(var Msg: TMessage); message WM_DeviceChange;
  public
    { public declarations }
  end;

procedure TForm1.WMDeviceChange(var Msg: TMessage);
const
  DBT_QUERYCHANGECONFIG = $0017;
  DBT_CONFIGCHANGED = $0018;
  DBT_CONFIGCHANGECANCELED = $0019;
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEQUERYREMOVE = $8001;
  DBT_DEVICEQUERYREMOVEFAILED = $8002;
  DBT_DEVICEREMOVEPENDING = $8003;
  DBT_DEVICEREMOVECOMPLETE = $8004;
  DBT_DEVICETYPESPECIFIC = $8005;
  DBT_USERDEFINED = $FFFF;
var
  tmpStr: string;
begin
  inherited
    case Msg.wParam of
    DBT_DEVICEARRIVAL:
      tmpStr := 'CD inserted in drive';
    DBT_DEVICEREMOVECOMPLETE:
      tmpSTr := 'CD removed from drive';
  end;
  ShowMessage(tmpStr);
end;

How to determine what control a TPopupMenu was activated for

Problem/Question/Abstract:

How can the event handler of a popup menu item determine which component was right-clicked upon to activate that menu?

Answer:

Use the PopupMenu.PopupComponent property to determine what control the menu was activated for:


procedure TForm1.PopupItem1Click(Sender: TObject);
begin
  Label1.Caption := PopupMenu1.PopupComponent.ClassName;
end;


The form's ActiveControl property can also be used, however, the active control may not necessarily be the control that caused the popup menu to appear.

How to Use Adobe Acrobat (PDF) Files in a Delphi Application

Problem/Question/Abstract:

How to Use Adobe Acrobat (PDF) Files in a Delphi Application

Answer:

Let's see how to to show an Adobe Acrobat (.PDF) file in a Delphi application. All you need to do is the Acrobat ActiveX control (pdf.ocx and pdf.tlb), which you you can get for free from Adobe.

Here's How:

Start Delphi and select Component | Import ActiveX Control...
Look for the 'Acrobat Control for ActiveX (Version x.x)'  and simply click on Install.
Select the Component palette location in which you want to place selected library.
Maybe the best is to leave the ActiveX option selected.
Click on Install.
Select a package where the new component must be installed or create a new package for the new TPdf control.  Click on OK.
Delphi will prompt you whether you want to rebuild the modified/new package or not.  Click on Yes.
After the package is compiled, Delphi will show you a message saying that the new TPdf component was registered and already available as part of the VCL.
Close the package detail window, allowing Delphi to save the changes to it.
The component is now available in the ActiveX tab (if you didn't change this setting in step 4)  
Drop the component on a form.
Select the TPdf component you just dropped on a blank form.
Using the object inspector, set the src property to the name of an existing PDF file on your system. Now all you have to do is resize the component and read the PDF file from your Delphi application.


Tips:

If you do not have the Acrobat ActiveX control, download it now! It will be required for tip to work.
Last step (Step 15) can be done in runtime, so you can open and close files programmatically, as well as resize the control.

Closing acrobat reader on formdestroy:

procedure Tfrm_doc_pdf.FormDestroy(Sender: TObject);
var
  xHWND: integer;
begin
  xHWND := findwindow(nil, 'Acrobat Reader');
  sendmessage(xHWND, WM_CLOSE, 0, 0);
end;

Testing new component without installing it

Problem/Question/Abstract:

How can I test a component without installing it?

Answer:

If you are developing a new component, it takes a lot of time to test every change by installing the component. But there is a easier way to do this:

First, create a new project.

Then add the unit with the component's source code to the 'uses ...' line.

The last thing you have to do is to add the OnCreate event of your form an add the code as shown in the following example.

procedure TForm1.FormCreate(Sender: TObject);
begin
  with TComponent1.Create(self) do
  begin
    Parent := self; // This makes the component visible at runtime
    {now you can define the values for other properties }
    Caption := '...';
    Left := 100;
    Top := 100;
    {...}
  end;
end;

Make a program only run once per Windows session

Problem/Question/Abstract:

How can I prevent the user from running my program twice during the same Windows session? I want to force the user to log into Windows again before my application can be started a second time.

Answer:

A way to make a program only be able to run once in every session is to create a unique global atom string on first run. Then on the following run, check if the string exists, and not run the program if the string atom is present. For example:

procedure TForm1.FormShow(Sender: TObject);
var
  atom: Integer;
begin
  if (GlobalFindAtom('This_is_some_unique_text') = 0) then
    atom := GlobalAddAtom('This_is_some_unique_text')
  else
  begin
    ShowMessage('This application can only be run once for every Windows Session.');
    Close;
  end;
end;

How to set the PixelsPerInch property of a TPrinter

Problem/Question/Abstract:

How to set the PixelsPerInch property of a TPrinter

Answer:

When changing printers, be aware that fontsizes may not always scale properly. To ensure proper scaling, set the PixelsPerInch property of the font after changing the printer index property. Be sure not to make the change until you have started the print job.

Here are two examples:

uses
  Printers;

var
  MyFile: TextFile;
begin
  Printer.PrinterIndex := 2;
  AssignPrn(MyFile);
  Rewrite(MyFile);
  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.Font.PixelsPerInch := GetDeviceCaps(Printer.Canvas.Handle,
    LOGPIXELSY);
  Writeln(MyFile, 'Print this text');
  System.CloseFile(MyFile);
end;

uses
  Printers;

begin
  Printer.PrinterIndex := 2;
  Printer.BeginDoc;
  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.Font.PixelsPerInch := GetDeviceCaps(Printer.Canvas.Handle,
    LOGPIXELSY);
  Printer.Canvas.Textout(10, 10, 'Print this text');
  Printer.EndDoc;
end;

Some useful date calculation routines

Problem/Question/Abstract:

Some useful date calculation routines

Answer:

Ever notice how some date routines are missing from SysUtils? Well as they say, necessity is the mother of invention, I've come up with some date calculation routines that you can include in your own programs that require some date calculations. If you've got any more than this, please feel free to share them!

type
  TDatePart = (dpYear, dpMonth, dpDay);

  {Purpose  : Return a date part.}

function GetDatePart(Date: TDateTime; DatePart: TDatePart): Word;
var
  D, M, Y: Word;
begin
  //Initialize Result - avoids compiler warning
  Result := 0;
  DecodeDate(Date, Y, M, D);
  case DatePart of
    dpYear: Result := Y;
    dpMonth: Result := M;
    dpDay: Result := D;
  end;
end;

{Purpose  : Extracts the date portion of a date time. Useful for
            seeing if two date time values fall on the same day}

function ExtractDatePart(Date: TDateTime): TDate;
begin
  Result := Int(Date);
end;

{Purpose  : Gets the time portion of a date time. Like ExtractDatePart
            this is useful for comparing times.}

function ExtractTimePart(Date: TDateTime): TTime;
begin
  Result := Frac(Date);
end;

{Purpose  : Used for determining whether or not a DateTime is
            a weekday.}

function IsWeekday(Day: TDateTime): Boolean;
begin
  Result := (DayOfWeek(Day) >= 2) and (DayOfWeek(Day) <= 6);
end;

{Purpose  :  Function returns the date of the relative day of a
             month/year combo such as the date of the "Third
             Monday of January." The formal parameters depart a bit
             from the MS SQL Server Schedule agent constants in that
             the RelativeFactor parameter (Freq_Relative_Interval in
             MS-SQL), takes integer values from 1 to 5 as opposed to
             integer values from 2 to the 0th to 2 to the 4th power.

Formal Parameters
======================================================================================
Year            : Year in question
Month           : Month in question
RelativeFactor  : 1 = First; 2 = Second; 3 = Third; 4 = Fourth; 5 = Last
Day             : 1 - 7, day starting on Sunday; 8 = Day;
                  9 = Weekday; 10 = Weekend Day
}

function GetRelativeDate(Year, Month,
  RelativeFactor, Day: Integer): TDateTime;
var
  TempDate: TDateTime;
  DayIndex: Integer;
begin
  TempDate := EncodeDate(Year, Month, 1);
  DayIndex := 0;
  //Now, if you're looking for the last day, just go to the last
  //day of the month, and count backwards until you hit the day
  //you're interested in.
  if (RelativeFactor = 5) then
  begin
    TempDate := EncodeDate(Year, Month, MonthDays[IsLeapYear(Year), Month]);
    case Day of
      1..7:
        if (DayOfWeek(TempDate) = Day) then
          Result := TempDate
        else
        begin
          while (DayOfWeek(TempDate) <> Day) do
            TempDate := TempDate - 1;
          Result := TempDate;
        end;
      9:
        begin
          if IsWeekday(TempDate) then
            Result := TempDate
          else
          begin
            while not IsWeekday(TempDate) do
              TempDate := TempDate - 1;
            Result := TempDate;
          end;
        end;
      10:
        begin
          if not IsWeekday(TempDate) then
            Result := TempDate
          else
          begin
            while IsWeekday(TempDate) do
              TempDate := TempDate - 1;
            Result := TempDate;
          end;
        end;
    else
      //This only happens if you're going after the very last day of the month
      Result := TempDate;
    end;
  end
  else
    //Otherwise, you have to go through the month day by day until you get
    //to the day you want. Since the relative week is a power of 2, just
    //see if the day exponent is a
    case Day of
      1..7:
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if (DayOfWeek(TempDate) = Day) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
      9:
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if IsWeekDay(TempDate) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
      10:
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if not IsWeekDay(TempDate) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
    else
      Result := TempDate + RelativeFactor;
    end;
end;

type
  TDecimalTimeType = (dtSecond, dtMinute, dtHour);

  {Purpose  : Returns hours, minutes, or seconds in decimal format for use
              in date time calculations}

function GetDecimalTime(Count: Integer;
  DecimalTimeType: TDecimalTimeType): Double;
const
  Second = 1 / 86400;
  Minute = 1 / 1440;
  Hour = 1 / 24;
begin
  //Initialize result
  Result := 0;
  case DecimalTimeType of
    dtSecond: Result := Count * Second;
    dtMinute: Result := Count * Minute;
    dtHour: Result := Count * Hour;
  end;
end;

{Purpose  : Converts a MS-style integer time to a TTime}

function IntTimeToTime(Time: Integer): TTime;
var
  S: string;
begin
  S := IntToStr(Time);
  //String must be 5 or 6 character long
  if (Length(S) < 5) or (Length(S) > 6) then
    Result := 0
  else
  begin
    if (Length(S) = 5) then //A morning time
      S := Copy(S, 1, 1) + ':' + Copy(S, 2, 2) + ':' + Copy(S, 4, 2)
    else //Afternoon, evening time
      S := Copy(S, 1, 2) + ':' + Copy(S, 3, 2) + ':' + Copy(S, 5, 2);
    Result := StrToTime(S);
  end;
end;

How to read the value of a component property directly from its resource

Problem/Question/Abstract:

Does anyone know if there is an easy way to load the value of a component's property directly from its resource without creating the component? Something like:

if ReadPropertyValue('Form1.Button1', 'width') > 1000 then
  ShowMessage('You are about to create a big button!');

Answer:

function TForm1.ReadProp(r: TReader): string;
begin
  result := '';
  {Determine the value type of the property, read it with the appropriate method
  of TReader and convert it to string. Not all value types are implemented here
  but you get the idea.}
  case r.NextValue of
    vaInt8, vaInt16, vaInt32:
      result := IntToStr(r.ReadInteger);
    vaExtended:
      result := FloatToStr(r.ReadFloat);
    vaString:
      result := r.ReadString;
  else
    r.SkipValue; {Not implemented}
  end;
end;

procedure TForm1.ReadRes(PropPath: string; r: TReader);
var
  p: string;
begin
  {Skip the class name}
  r.ReadStr;
  {Construct the property path}
  if PropPath = '' then
    p := r.ReadStr
  else
    p := PropPath + '.' + r.ReadStr;
  {Read all properties and its values and fill them into the memo}
  while not r.EndOfList do
    Memo1.Lines.Add(p + '.' + r.ReadStr + ' = ' + ReadProp(r));
  {Skip over the end of the list of the properties of this component}
  r.CheckValue(vaNull);
  {Recursively read the properties of all sub-components}
  while not r.EndOfList do
  begin
    ReadRes(p, r);
    r.CheckValue(vaNull);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  strm: TResourceStream;
  Reader: TReader;
begin
  strm := TResourceStream.Create(HInstance, 'TForm1', RT_RCDATA);
  Reader := TReader.Create(strm, 1024);
  try
    Memo1.Clear;
    Reader.ReadSignature;
    ReadRes('', Reader);
  finally
    Reader.Free;
    strm.Free;
  end;
end;

Only one small problem.
r.SkipValue was protected (in D5) but I hacked that out with the following code:

type
  THackReader = class(TReader);
  { ... }
  THackReader(r).SkipValue;

And now it works like a charm.

How to eliminate flickering without using LockWindowUpdate(Handle)

Problem/Question/Abstract:

I have an application in which the user drags TImage descendants around on a background image. When an image is dropped, I have to run through all the current images finding out where they are, and then arrange their z-order appropriately. When I do this, there's significant flickering. I've tried calling LockWindowUpdate(Handle) before the operation, then LockWindowUpdate(0) at the end, but several repaint operations still seem to take place at once. I'd like to be able to repaint the whole form once only, or failing that, limit the repaint to a specific area of the form (so that all my buttons etc, which aren't involved in any of this, don't have to flicker too).

Answer:

Below is a fragment of code implementing reference counted form redraw locking. I use it in my apps where any form is derived from TLwForm (subclass of TForm). It suggests locking not limited to one window as it's the case with LockWindowUpdate. The approach can be applied not to the form as the whole but, via iteration, to all its TWinControl children.

var
  FLockFormUpdatePile: integer;

procedure TLwForm.LockFormUpdate;
begin
  if FLockFormUpdatePile = 0 then
    Perform(WM_SetRedraw, 0, 0);
  inc(FLockFormUpdatePile);
end;

procedure TLwForm.UnlockFormUpdate;
begin
  dec(FLockFormUpdatePile);
  if FLockFormUpdatePile = 0 then
  begin
    Perform(WM_SetRedraw, 1, 0);
    RedrawWindow(Handle, nil, 0, RDW_FRAME + RDW_INVALIDATE +
      RDW_ALLCHILDREN + RDW_NOINTERNALPAINT);
  end;
end;

How to determine the width of a TMainMenu

Problem/Question/Abstract:

How do I determine the width of a TMainMenu? I want to ensure that the form is not resized to less than the width of the TMainMenu on the form.

Answer:

The menu bar will automatically wrap when that happens, so it is not a catastrophy. There is a GetMenuItemRect API function you may want to try to get the information you are after.

procedure TForm1.Button1Click(Sender: TObject);
var
  r: TRect;
  i: Integer;
begin
  for i := 0 to mainmenu1.Items.Count - 1 do
  begin
    Win32Check(GetMenuItemrect(handle, mainmenu1.handle, i, r));
    memo1.lines.add(format('Item %d: (%d, %d), (%d, %d)', [i, r.left, r.top, r.right,
      r.bottom]));
  end;
end;

Note that the coordinates returned are screen-coordinates.

Capture text from another non-Delphi application window

Problem/Question/Abstract:

I need to capture the text from a scrolling text window in another program that I don't have access to only through a window handle. Can I use SendMEssage or something to ge the text with WM_GETTEXT type message. I know there are programs like spell checkers that can do this. Any help would be appreciated.

Answer:

Solve 1:

The example runs 'chkdsk.exe c:\' and displays the output to Memo1. Put a TMemo (Memo1) and a TButton (Button1) on your form. Put this code in the OnCLick of Button1:

procedure TForm1.Button1Click(Sender: TObject);

  procedure RunDosInMemo(DosApp: string; AMemo: TMemo);
  const
    ReadBuffer = 2400;
  var
    Security: TSecurityAttributes;
    ReadPipe, WritePipe: THandle;
    start: TStartUpInfo;
    ProcessInfo: TProcessInformation;
    Buffer: Pchar;
    BytesRead: DWord;
    Apprunning: DWord;
  begin
    with Security do
    begin
      nlength := SizeOf(TSecurityAttributes);
      binherithandle := true;
      lpsecuritydescriptor := nil;
    end;
    if Createpipe(ReadPipe, WritePipe, @Security, 0) then
    begin
      Buffer := AllocMem(ReadBuffer + 1);
      FillChar(Start, Sizeof(Start), #0);
      start.cb := SizeOf(start);
      start.hStdOutput := WritePipe;
      start.hStdInput := ReadPipe;
      start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
      start.wShowWindow := SW_HIDE;
      if CreateProcess(nil, PChar(DosApp), @Security, @Security, true,
        NORMAL_PRIORITY_CLASS, nil, nil, start, ProcessInfo) then
      begin
        repeat
          Apprunning := WaitForSingleObject(ProcessInfo.hProcess, 100);
          Application.ProcessMessages;
        until
          (Apprunning <> WAIT_TIMEOUT);
        repeat
          BytesRead := 0;
          ReadFile(ReadPipe, Buffer[0],
            ReadBuffer, BytesRead, nil);
          Buffer[BytesRead] := #0;
          OemToAnsi(Buffer, Buffer);
          AMemo.Text := AMemo.text + string(Buffer);
        until
          (BytesRead < ReadBuffer);
      end;
      FreeMem(Buffer);
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
      CloseHandle(ReadPipe);
      CloseHandle(WritePipe);
    end;
  end;

begin {Button1 code}
  RunDosInMemo('chkdsk.exe c:\', Memo1);
end;

Unfortunaly that will only work with applications that send output to stdout. A Windows application usually doesn't do this.


Solve 2:

The usually use different techiques, like OCR on a screen bitmap. There is simply no generic method to get text from other windows. What you can try, however, is this:

function GetTextFromWindow(wnd: HWND): string;
var
  count: Cardinal;
begin
  result := '';
  if SendMessageTimeout(wnd, WM_GETTEXTLENGTH, 0, 0,
    SMTO_ABORTIFHUNG, 1000, count) <> 0 then
  begin
    if count = 0 then
      Exit;
    SetLength(result, count);
    if SendMessageTimeout(wnd, WM_GETTEXT, count + 1, lparam(@result[1]),
      SMTO_ABORTIFHUNG, 1000, count) = 0 then
      result := '';
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  wnd: HWND;
begin
  wnd := FindWindow('notepad', nil);
  if wnd <> 0 then
  begin
    wnd := GetWindow(wnd, GW_CHILD);
    if wnd <> 0 then
      memo1.text := GetTextfromwindow(wnd);
  end
  else
    memo1.text := 'Notepad not running.';
end;

Change the font properties of a certain row or column in a TStringGrid

Problem/Question/Abstract:

How to change the font properties of a certain row or column in a TStringGrid

Answer:

You can do it by handling the OnDrawCell event.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  StringGrid1.Canvas.FillRect(Rect);
  if ARow = 1 then {Use ACol for column or use both for a cell}
  begin
    StringGrid1.Canvas.Font.Color := clBlue;
    StringGrid1.Canvas.Font.Name := 'Tahoma';
    StringGrid1.Canvas.Font.Style := StringGrid1.Canvas.Font.Style + [fsBold];
  end;
  DrawText(StringGrid1.Canvas.Handle, PChar(StringGrid1.Cells[ACol, ARow]), -1,
    Rect, DT_SINGLELINE or DT_VCENTER or DT_LEFT);
end;

Change fonts between columns in a TStringGrid (2)

Problem/Question/Abstract:

How can I code the Fixed Row in Bold (font) style whereas Normal Rows in Normal style for TStringGrid component?

Answer:

You need to handle the OnDrawCell event.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  Fmt: integer;
begin
  StringGrid1.Canvas.FillRect(Rect);
  {set bold for fixed cells, also set alignment}
  if gdFixed in State then
  begin
    StringGrid1.Canvas.Font.Style := [fsBold];
    Fmt := DT_SINGLELINE or DT_VCENTER or DT_CENTER;
  end
  else
    Fmt := DT_SINGLELINE or DT_VCENTER or DT_LEFT;
  DrawText(StringGrid1.Canvas.Handle, PChar(StringGrid1.Cells[ACol, ARow]), -1, Rect,
    Fmt);
end;

How to make a form non-moveable

Problem/Question/Abstract:

How to make a form non-moveable

Answer:

It is easy to make a form non-moveable.
Choose a borderstyle like bsDialog so that the window can not be resized.

Then add an handler for the WM_WINDOWPOSCHANGING message and override the change.


type
  TMyForm = class(TForm)
  protected
    procedure OnPosChange(var Msg: TWmWindowPosChanging); message
      WM_WINDOWPOSCHANGING;
  end;

procedure TForm1.OnPosChange(var Msg: TWmWindowPosChanging);
begin
  Msg.WindowPos.x := Left;
  Msg.WindowPos.y := Top;
  Msg.Result := 0;
end;

Counting occurrences in a string

Problem/Question/Abstract:

A function that returns the number of times a substring occurs in a string. There's also an ANSI version.

Answer:

The following functions return the number of occurrences of a char or a substring within a string or ANSI string:

interface

function Occurs(const str: string; c: char): integer; overload;
function Occurs(const str: string; const substr: string): integer;
overload;
function AnsiOccurs(const str: string; const substr: string): integer;

implementation

uses sysutils;

function Occurs(const str: string; c: char): integer;
// Returns the number of times a character occurs in a string
var
  p: PChar;
begin
  Result := 0;
  p := PChar(Pointer(str));
  while p <> nil do
  begin
    p := StrScan(p, c);
    if p <> nil then
    begin
      inc(Result);
      inc(p);
    end;
  end;
end;

function Occurs(const str: string; const substr: string): integer;
// Returns the number of times a substring occurs in a string
var
  p, q: PChar;
  n: integer;
begin
  Result := 0;
  n := Length(substr);
  if n = 0 then
    exit;
  q := PChar(Pointer(substr));
  p := PChar(Pointer(str));
  while p <> nil do
  begin
    p := StrPos(p, q);
    if p <> nil then
    begin
      inc(Result);
      inc(p, n);
    end;
  end;
end;

function AnsiOccurs(const str: string; const substr: string): integer;
// Returns the number of times a substring occurs in a string
// ANSI version
var
  p, q: PChar;
  n: integer;
begin
  Result := 0;
  n := Length(substr);
  if n = 0 then
    exit;
  q := PChar(Pointer(substr));
  p := PChar(Pointer(str));
  while p <> nil do
  begin
    p := AnsiStrPos(p, q);
    if p <> nil then
    begin
      inc(Result);
      inc(p, n);
    end;
  end;
end;

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

How to check if the mouse cursor is outside a TForm

Problem/Question/Abstract:

How can I find out if the cursor is leaving a Delphi form?

Answer:

Solve 1:

Add a handler for the CM_MOUSELEAVE message to the form:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
  private
    { Private declarations }
    procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CMMouseEnter(var msg: TMessage);
begin
  if msg.lparam = 0 then
    memo1.Lines.add('Entered ' + Name)
  else
    memo1.Lines.add('Entered ' + TControl(msg.lparam).Name);
end;

procedure TForm1.CMMouseLeave(var msg: TMessage);
begin
  if msg.lparam = 0 then
    memo1.Lines.add('Left ' + Name)
  else
    memo1.Lines.add('Left ' + TControl(msg.lparam).Name);
end;

end.


Solve 2:

Place the following code in your form's OnMouseMove event handler, and you'll see SetCapture/ ReleaseCapture in action (plus its side-effects):

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if (GetCapture < > Handle) then {OnMouseEnter}
  begin
    Beep;
    Caption := 'Hello';
    SetCapture(Handle);
  end
  else if (PtInRect(ClientRect, Point(X, Y))) then {OnMouseOver}
    Caption := 'X=' + IntToStr(X) + ':Y=' + IntToStr(Y)
  else {OnMouseOut}
  begin
    Beep;
    Caption := 'Goodbye!';
    ReleaseCapture;
  end;
end;

How to remove the title bar of a MDI child form

Problem/Question/Abstract:

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

Answer:

Solve 1:

type
  TForm2 = class(TForm)
    {other stuff above}
    procedure CreateParams(var Params: TCreateParams); override;
    {other stuff below}
  end;

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and not WS_OVERLAPPEDWINDOW or WS_BORDER
end;


Solve 2:

For a MDI child form, setting the BorderStyle to bsNone does not remove the title bar. This does it:

procedure tMdiChildForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and (not WS_CAPTION);
end;

How to get a list of the applications that will appear on the Windows Taskbar

Problem/Question/Abstract:

I am trying to get a list of the windows that will appear on the Taskbar (and perhaps on Alt-Tab). I have tried to find the ones with no parent windows, etc. but I cannot find the pattern.

Answer:

As far as I know it has never been explicitly documented which criteria Windows uses here. Try the following:

function EnumWindowsProc(Wnd: HWND; LParam: LPARAM): BOOL; stdcall;
begin
  Result := True;
  if (IsWindowVisible(Wnd) or IsIconic(wnd)) and
    ((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or
    (GetWindowLong(Wnd, GWL_HWNDPARENT) = GetDesktopWindow)) and
    { skip WS_EX_TOOLWINDOW windows }
  (GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then
  begin
    { place code here }
  end;
end;

How to set tabstops in a TRichEdit

Problem/Question/Abstract:

How can I set the positions for tabstops in general? I mean, they should be active when a new TRichEdit is opened or when an open TRichEdit is filled with text via LoadFromFile. I tried it with paragraph.tab but it doesn't do what I want.

Answer:

The property is somewhat screwed up, best use the API way directly: The positions need to be specified in twips (1/1440 inch) for the EM_SETPARAFORMAT message. The following method sets tabstops every 5 average character positions, based on the current paragraphs font.

procedure TForm1.Button2Click(Sender: TObject);
const
  tabs: array[0..5] of Integer = (5, 10, 15, 20, 25, 30);
  teststring = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
var
  pf: TParaFormat;
  i: Integer;
  charwidth: Integer;
begin
  FillChar(pf, sizeof(pf), 0);
  pf.cbSize := SizeOf(pf);
  pf.dwmask := PFM_TABSTOPS;
  pf.cTabCount := 6;
  Canvas.Font.Assign(richedit1.SelAttributes);
  {average charwidth in twips}
  charwidth := (Canvas.TextWidth(teststring) * 1440) div (Screen.PixelsPerInch *
    Length(teststring));
  for i := 0 to High(tabs) do
    pf.rgxTabs[i] := tabs[i] * charwidth;
  if richedit1.perform(EM_SETPARAFORMAT, 0, Integer(@pf)) = 0 then
    ShowMessage('Failed');
end;

Add the Richedit unit to your Uses clause. If you do this setting on an empty richedit control it will become the default for new text entered. If you read in formatted text you would have to do a selectAll, then set the tabstops,to make them effective for the loaded text.

How to remove characters from a string

Problem/Question/Abstract:

We need a workable function that can strip embedded characters (single qoutes, double quotes, etc.,) from within string vars.

Answer:

Solve 1:

Here is a general method to remove characters from a string:


type
  TCharSet = set of Ansichar;

procedure RemoveCharacters(var S: AnsiString; const characters: TCharset);
var
  i: Integer;
begin
  for i := Length(S) downto 1 do
    if S[i] in characters then
      delete(S, i, 1);
end;


In your case you would call it as:


RemoveCharacters(aString, [' ']);


There are certainly faster ways to implement this but unless you call the procedure some ten-thousand times in a loop I would not worry about that.


Solve 2:

function RemoveCharsFromString(const TheString: string; const CharsToRemove: array
  of Char): string;
var
  i:
  Integer;
begin
  Result := TheString;
  for i := Low(CharsToRemove) to High(CharsToRemove) do
  begin
    Result := StringReplace(Result, CharsToRemove[i], '', [rfReplaceAll]);
  end;
end;


Solve 3:

type
  TSetOfChar = set of char;

function RemoveCharsFromString(const TheString: string;
  const CharsToRemove: TSetOfChar): string;
var
  i, j: Integer;
begin
  SetLength(Result, length(TheString));
  j := 0;
  for i := 1 to length(TheString) do
  begin
    if not (TheString[i] in CharsToRemove) then
    begin
      inc(j);
      Result[j] := TheString[i];
    end;
  end;
  SetLength(Result, j);
end;

Get the correct height of a TDBText

Problem/Question/Abstract:

I have a TDBText with WordWrap = True and it is anchored to the left and right of the form. As the form resizes, the height of the TDBText changes. Is there any way of knowing the height of the TDBText? TDBText.Height doesn't return the correct value.

Answer:

TDBText is a descendant of TCustomLabel, so this should work:

{ ... }
type
  TLabelCracker = class(TCustomLabel)
  end;

function LabelTextHeight(ALabel: TCustomLabel): Integer;
const
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
  Rect: TRect;
begin
  Rect := ALabel.ClientRect;
  TLabelCracker(ALabel).DoDrawText(Rect, (DT_EXPANDTABS or DT_CALCRECT) or
    WordWraps[TLabelCracker(ALabel).WordWrap]);
  Result := Rect.Bottom - Rect.Top;
end;

How to update the IndexDefs property of a TTable

Problem/Question/Abstract:

Why is it that when I create a table using the TTable component's CreateTable method it creates the fields correctly but does not create the indexes even though I do a NewTable.IndexDefs.Assign(Table1.IndexDefs)?

Answer:

This is the correct way to transfer the index definition to NewTable, however, the IndexDefs property of Table1 may not be up-to-date so you need to call the Update method of Table1's IndexDefs property prior to its assignment to NewTable like this example shows:

with NewTable do
begin
  Active := False;
  DatabaseName := 'DBDEMOS';
  TableName := 'Temp';
  TableType := ttParadox;
  FieldDefs.Assign(Table1.FieldDefs);
  Table1.IndexDefs.Update; { Do an update first }
  IndexDefs.Assign(Table1.IndexDefs);
  CreateTable;
end;

Function to determine MS SQL Server Version Number

Problem/Question/Abstract:

How to determine MS SQL Server version number

Answer:

This function gets the connected MS SQL Server version. It returns the version info in 3 OUT parameters.

        VerNum                        : double         eg. 7.00623
        VerStrShort         : string                 eg. '7.00.623'
        VerStrLong         : string                 eg. 'Microsoft SQL Server  7.00 - 7.00.623 (Intel X86)         Nov 27 1998 22:20:07                                                             Copyright (c) 1988-1998 Microsoft Corporation        Enterprise Edition on                                                                   Windows NT 5.0 (Build 2195: Service Pack 1)'

I have tested it with MSSQL 7 and MSSQL 2000. I assume it should work for the others. Any feedback and fixes for different versions would be appreciated.

The TQuery parameter that it recieves is a TQuery component that is connected to an open database connection.

procedure GetSqlVersion(Query: TQuery;
  out VerNum: double;
  out VerStrShort: string;
  out VerStrLong: string);
var
  sTmp, sValue: string;
  i: integer;
begin
  // @@Version does not return a Cursor.
  // Read the value from the Record Buffer
  // Can be used to read all sys functions from MS Sql
  sValue := '';
  Query.SQL.Text := 'select @@Version';
  Query.Open;
  SetLength(sValue, Query.RecordSize + 1);
  Query.GetCurrentRecord(PChar(sValue));
  SetLength(sValue, StrLen(PChar(sValue)));
  Query.Close;

  if sValue <> '' then
    VerStrLong := sValue
  else
  begin
    // Don't know this version
    VerStrLong := '?';
    VerNum := 0.0;
    VerStrShort := '?.?.?.?';
  end;

  if VerStrLong <> '' then
  begin
    sTmp := trim(copy(VerStrLong, pos('-', VerStrLong) + 1, 1024));
    VerStrShort := copy(sTmp, 1, pos(' ', sTmp) - 1);
    sTmp := copy(VerStrShort, 1, pos('.', VerStrShort));

    for i := length(sTmp) + 1 to length(VerStrShort) do
    begin
      if VerStrShort[i] <> '.' then
        sTmp := sTmp + VerStrShort[i];
    end;

    VerNum := StrToFloat(sTmp);
  end;
end;

Getting the length of a Wav file

Problem/Question/Abstract:

How do I get the length of a Wav file without using a TMediaPlayer to open the file?

Answer:

Getting the length is possible using the MCI_SENDSTRING API call, but that does get involved. However, a better method has been suggested that accesses the file directly and interprets its own internal data to obtain the information.

Here is the function:

function GetWaveLength(WaveFile: string): Double;
var
  ��groupID: array[0..3] of char;
  ��riffType: array[0..3] of char;
  ��BytesPerSec: Integer;
  ��Stream: TFileStream;
  ��dataSize: Integer;
  // chunk seeking function,
  // -1 means: chunk not found

  function GotoChunk(ID: string): Integer;
  var
    ��chunkID: array[0..3] of char;
    ��chunkSize: Integer;
  begin
    ��Result := -1;

    with Stream do
      ��begin
        ���� // index of first chunk
      ����Position := 12;
    ����repeat
      ������ // read next chunk
    ������Read(chunkID, 4);
    ������Read(chunkSize, 4);
    �������if chunkID <> ID then
      ������ // skip chunk
    �����Position := Position + chunkSize;
    ������until(chunkID = ID) or (Position >= Size);
    ������if chunkID = ID then
      �������� // chunk found,
    �������� // return chunk size
    ��������Result := chunkSize;
    ����end;
  end;

begin
  ��Result := -1;
  ��Stream := TFileStream.Create(WaveFile, fmOpenRead or fmShareDenyNone);
  ��with Stream do
    ����try
    ������Read(groupID, 4);
  ������Position := Position + 4; // skip four bytes (file size)
  ������Read(riffType, 4);

  ������if(groupID = 'RIFF') and (riffType = 'WAVE') then
    �������begin
    ��������� // search for format chunk
  ���������if GotoChunk('fmt') <> -1 then
    ����������begin
    ����������� // found it
  ������������Position := Position + 8;
  ������������Read(BytesPerSec, 4);
  �������������� //search for data chunk
  ��������������dataSize := GotoChunk('data');

  ��������������if dataSize <> -1 then
    ���������������� // found it
  ����������������Result := dataSize / BytesPerSec
    ������������end
    ��������end
    ����finally
    ������Free;
  ����end;
end;

This returns the number of seconds as a floating point number, which is not necessarily the most helpful format. Far better to return it as a string representing the time in hours, minutes and seconds. The following function achieves this based on the number of seconds as an integer:

function SecondsToTimeStr(RemainingSeconds: Integer): string;
var
  ��Hours, Minutes, Seconds: Integer;
  ��HourString, MinuteString, SecondString: string;
begin
  �� // Calculate Minutes
  ��Seconds := RemainingSeconds mod 60;
  ��Minutes := RemainingSeconds div 60;
  ��Hours := Minutes div 60;
  ��Minutes := Minutes - (Hours * 60);

  ��if Hours < 10 then
    ���HourString := '0' + IntToStr(Hours) + ':'
    �else
    ���HourString := IntToStr(Hours) + ':';

  ��if Minutes < 10 then
    ����MinuteString := '0' + IntToStr(Minutes) + ':'
    ��else
    ����MinuteString := IntToStr(Minutes) + ':';

  ��if Seconds < 10 then
    ����SecondString := '0' + IntToStr(Seconds)
    ��else
    ����SecondString := IntToStr(Seconds);
  ��Result := HourString + MinuteString + SecondString;
end;

Having created these functions you can call them from any relevant event - for example a button click:

procedure TForm1.Button1Click(Sender: TObject);
var
  �Seconds: Integer;
begin
  ��Seconds := Trunc(GetWaveLength(Edit1.Text));
    //gets only the Integer part of the length
  ��Label1.Caption := SecondsToTimeStr(Seconds);
end;

You can even reduce this to a single line of code if you prefer:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ��Label1.Caption := SecondsToTimeStr(Trunc(GetWaveLength(Edit1.Text)));
end;

Object List(String) Using TList

Problem/Question/Abstract:

Object List(String) Using TList

Answer:

Couldn't find too many examples on the net of how to do this so here it is.

Here some code for all you newbies(like myself kinda). That will let you create your own objectlist.
I used code from a program that manages email accounts for this example..

add items via  accountlist.add(TAccount.Create(Server, User, Password);

uses classes;

type

  //Define the type of data for it to hold
  TAccount = class
  private
    fServer: string;
    fUser: string;
    fPassword: string;
  public
    constructor create(Server, User, Password: string);
    property Server: string read fServer write FServer;
    property User: string read fUser write FUser;
    property Password: string read fpassword write fpassword;
  end;
  // define the list
  TAccountList = class(TList)
  private
    function GetItem(AIndex: Integer): TAccount;
  public
    constructor create;
    destructor Destroy; override;
    function add(Account: TAccount): integer;
    property Items[AIndex: Integer]: TAccount read getitem;
  end;
implementation

constructor TAccount.create(Server, User, Password: string);
begin
  fserver := Server;
  fUser := User;
  fPassword := Password;
end;

constructor TAccountlist.create;
begin
  inherited Create;
end;

destructor TAccountList.Destroy;
begin
  try
    Clear;
  finally
    inherited Destroy;
  end;
end;

function TAccountlist.add(Account: TAccount): integer;
begin
  result := inherited Add(Account);
end;

function TAccountList.GetItem(AIndex: integer): TAccount;
begin
  result := TAccount(inherited Items[AIndex]);
end;

Simulate Mouse Clicks and Moves

Problem/Question/Abstract:

How can I simulate mouse clicks in my application written in Delphi?

Answer:

You can easily simulate mouse clicks or moves with the mouse_event-function. You can find more information about the parameters and flags for this function in the Delphi-helpfile.

This function can be useful when you can not control other applications by OLE or something like that.

Example:

You want to start an application, and doubleclick on an item which is at x,y-position 300,400 in this application. Put a TTimer on your form, set it to Disabled and try this example code:

procedure TForm1.FormCreateOrWhatever;
begin
  winexec('myexternalapplication.exe', sw_shownormal); // start app
  timer1.interval := 2000; // give the app 2 secs to start up
  timer1.enabled := true; // start the timer
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  point: TPoint; // point-structure needed by getcursorpos()
begin
  getcursorpos(point); // get current mouse position
  setcursorpos(300, 400); // set mouse cursor to menu item or whatever
  mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0); // click down
  mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0); // +click up = double click
  setcursorpos(point.x, point.y); // set cursor pos to origin pos
  timer1.enabled := false; // stop
end;

The timer is needed to give the application time to start up. Be sure you don't move the mouse while mouse_event is executed. That's it!

Undo Redo using Commands

Problem/Question/Abstract:

There are 2 ways to do undo - redo, one is with state, the other is using commands. This artical explains using commands and provides full source code implementation of a TUndoRedoManager

Answer:

This article will cover

Command
Requirements of a command
Command Stack
Undo redo manager
Command grouping
Full source code implementation

A command is simply an object that implements an action in the system, for example in a paint program a command may be a line command, or a circle command, or a rectangle command, and so on.  In order to implement command based undo redo you must design your editing to use command objects.

Because we want to undo and redo the effects of commands, the commands themselves must be able to undo and redo their own action as well as execute the initial action.
The primary methods of a command is

Execute
Undo
Redo

You may wonder why there is a seprate Redo instead of simply reusing the Execute method.  This is because the redo implementation may be different than the Execute.  For example, if this were a paint command.  The Execute may choose the brush and follow some algorithm to draw some sort of gradual transparent circle.  The redo could simply copy a image of the results of the paint rather than painting again.  In any case, if this functionality is not needed then simply call the Execute method from within your Redo method.

Ok, so now we have one command.  We need to remember the sequence of commands so we can have multilevel undo and redo.  This is the command stack.

When you undo, you take the last command and call its undo method.  The next time you undo, you call the undo method of the 2nd  command from the top and so on.  When you  redo, you call the redo method of the last command that you called undo on.  To simplify this we create 2 lists, an undo list and a redo list and encapsulate these with an undo manager.

For the undoredo manager, we give it 3 methods.
ExecuteCommand(Command)
Undo
Redo
Internally the UndoRedoManager will maintain 2 lists of commands, Undo and Redo

Here is the full sequence:

Execute a command by passing it to the ExecuteCommand method, internally the UndoRedoManager will call the Execute method of the command and then add the command to the top of the Undo list.
Calling undo, the manager will take the last command in the undo list, call its undo method and then remove the command from the undo list and add it to the redo list.
Calling redo will do the reverse of undo, it will take the last command from the redo list, call its redo method, then remove it from the redo list and add it to the top of the undo list
Now, the next time ExecuteCommand is called, we must prune the redo list... delete all commands in it.

Sometimes, or most of the time, you will execute a bunch of commands as a single group.  Calling undo and redo should undo and redo this entire group and not the individual commands within it one at a time.  An example might be some wizard that did a lot of things, you would want to undo and redo this as one group.

I'll add 2 methods to the UndoRedoManager
BeginTransaction
EndTransaction

All commands executed between calls to BeginTransaction and EndTransaction will be stored as one group. You should be allowed to make nested calls to BeginTransaction and EndTransaction.

Using inheritence, this can be easy to implement.  We make a command group class that inherits from the Command, that way the manager acts as if it is working with single commands.

Below is the Full source code of a working UndoRedoManager along with interfaces for IUndoRedoCommand and  IUndoRedoCommandGroup.  Note: I think a lot of people associate delphi interfaces with ActiveX or COM and then think that interfaces ARE ActiveX or COM.  This is not true, you can create classes that implement interfaces and those classes do not have any implementation of ActiveX or COM.  They do not require registering and all the things that go with COM or ActiveX.  You should keep in mind that interfaces are reference counted, they are freed when there are not more references.

unit UndoRedoCommand;

interface
uses
  Classes, SysUtils;

type
  IUndoRedoCommand = interface(IUnknown)
    ['{D84BFD00-8396-11D6-B4FA-000021D960D4}']
    procedure Execute;
    procedure Redo;
    procedure Undo;
  end;

  IUndoRedoCommandGroup = interface(IUndoRedoCommand)
    ['{9169AE00-839B-11D6-B4FA-000021D960D4}']
    function GetUndoRedoCommands: TInterfaceList;
    property UndoRedoCommands: TInterfaceList read GetUndoRedoCommands;
  end;

  TUndoRedoCommandGroup = class(TInterfacedObject, IUndoRedoCommandGroup,
      IUndoRedoCommand)
  private
    FList: TInterfaceList;
    FCanRedo: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Execute;
    function GetUndoRedoCommands: TInterfaceList;
    procedure Redo;
    procedure Undo;
    property UndoRedoCommands: TInterfaceList read GetUndoRedoCommands;
  end;

  TUndoRedoManager = class(TObject)
  private
    FRedoList: TInterfaceList;
    FUndoList: TInterfaceList;
    FTransactLevel: Integer;
    FTransaction: IUndoRedoCommandGroup;
    function GetCanRedo: Integer;
    function GetCanUndo: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginTransaction;
    procedure EndTransaction;
    procedure ExecCommand(const AUndoRedoCommand: IUndoRedoCommand);
    procedure Redo(RedoCount: Integer = 1);
    procedure Undo(UndoCount: Integer = 1);
    property CanRedo: Integer read GetCanRedo;
    property CanUndo: Integer read GetCanUndo;
  end;

implementation

{
**************************** TUndoRedoCommandGroup *****************************
}

constructor TUndoRedoCommandGroup.Create;
begin
  inherited Create;
  FList := TInterfaceList.Create;
end;

destructor TUndoRedoCommandGroup.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

procedure TUndoRedoCommandGroup.Execute;
var
  I: Integer;
begin
  for I := 0 to FList.Count - 1 do
    (FList[I] as IUndoRedoCommand).Execute;
end;

function TUndoRedoCommandGroup.GetUndoRedoCommands: TInterfaceList;
begin
  Result := FList;
end;

procedure TUndoRedoCommandGroup.Redo;
var
  I: Integer;
begin
  if FCanRedo then
  begin
    for I := 0 to FList.Count - 1 do
      (FList[I] as IUndoRedoCommand).Redo;

    FCanRedo := False;
  end
  else
    raise
      Exception.Create('Must call TUndoRedoCommandGroup.Undo before calling Redo.');
end;

procedure TUndoRedoCommandGroup.Undo;
var
  I: Integer;
begin
  if FCanRedo then
    raise Exception.Create('TUndoRedoCommandGroup.Undo already called');

  for I := FList.Count - 1 downto 0 do
    (FList[I] as IUndoRedoCommand).Undo;

  FCanRedo := True;
end;

{
******************************* TUndoRedoManager *******************************
}

constructor TUndoRedoManager.Create;
begin
  inherited Create;
  FRedoList := TInterfaceList.Create;
  FUndoList := TInterfaceList.Create;
end;

destructor TUndoRedoManager.Destroy;
begin
  FRedoList.Free;
  FUndoList.Free;
  inherited Destroy;
end;

procedure TUndoRedoManager.BeginTransaction;
begin
  Inc(FTransactLevel);
  if FTransactLevel = 1 then
    FTransaction := TUndoRedoCommandGroup.Create;
end;

procedure TUndoRedoManager.EndTransaction;
begin
  Dec(FTransactLevel);
  if (FTransactLevel = 0) then
  begin
    if FTransaction.UndoRedoCommands.Count > 0 then
    begin
      FRedoList.Clear;
      FUndoList.Add(FTransaction);
    end;
    FTransaction := nil;
  end
  else if FTransactLevel < 0 then
    raise
      Exception.Create('Unmatched TUndoRedoManager.BeginTransaction and EndTransaction');
end;

procedure TUndoRedoManager.ExecCommand(const AUndoRedoCommand:
  IUndoRedoCommand);
begin
  BeginTransaction;
  try
    FTransaction.UndoRedoCommands.Add(AUndoRedoCommand);
    AUndoRedoCommand.Execute;
  finally
    EndTransaction;
  end;
end;

function TUndoRedoManager.GetCanRedo: Integer;
begin
  Result := FRedoList.Count;
end;

function TUndoRedoManager.GetCanUndo: Integer;
begin
  Result := FUndoList.Count;
end;

procedure TUndoRedoManager.Redo(RedoCount: Integer = 1);
var
  I: Integer;
  Item: IUndoRedoCommand;
  RedoLast: Integer;
begin
  if FTransactLevel <> 0 then
    raise Exception.Create('Cannot Redo while in Transaction');

  // Index of last redo item
  RedoLast := FRedoList.Count - RedoCount;
  if RedoLast < 0 then
    RedoLast := 0;

  for I := FRedoList.Count - 1 downto RedoLast do
  begin
    Item := FRedoList[I] as IUndoRedoCommand;
    FRedoList.Delete(I);
    FUndoList.Add(Item);
    Item.Redo;
  end;
end;

procedure TUndoRedoManager.Undo(UndoCount: Integer = 1);
var
  I: Integer;
  Item: IUndoRedoCommand;
  UndoLast: Integer;
begin
  if FTransactLevel <> 0 then
    raise Exception.Create('Cannot undo while in Transaction');

  // Index of last undo item
  UndoLast := FUndoList.Count - UndoCount;
  if UndoLast < 0 then
    UndoLast := 0;

  for I := FUndoList.Count - 1 downto UndoLast do
  begin
    Item := FUndoList[I] as IUndoRedoCommand;
    FUndoList.Delete(I);
    FRedoList.Add(Item);
    Item.Undo;
  end;
end;

end.

Implementing the Singleton pattern in delphi

Problem/Question/Abstract:

The Singleton pattern is one of the most usefull patterns. We all use it, with out our knowladge. Class are an example, TApplication is another.
Here i try to explain what a singleton is, and to bring a usefull example of singleton implementation.

Answer:

Abstruct

The singleton design pattern defines a variation to the normal Object - Class relation. The variation is that the class creates only one object for all the application, and returns that one object any time someone requests an object of that class.
Note that TComponent cannot be singleton, as TComponent object lifetime is handled by a owner, and a TComponent can have only one owner. Two owners cannot share the same object, so TComponent cannot be Singleton.

Implementing singleton

There are two ways to implement singleton objects:

Add a class function GetInstance, that returns the singleton instance. This method has the problem of allowing users to create new object using the Create function.

Change the Create function to return the singleton instance.

I have taken the second way. Why? Any function in delphi must have a return type, and this return type for a base singleton class can only be TSingelton. This will force users to typecast the result of the GetInstance function to the tree type of the singleton.

MySingleton := (TMySingleton.GetInstance) as TMySingleton;

However, a constructor allways returns the class beeing constructed. This removes the need to typecast.

MySingleton := TMySingleton.create;

You can also add a new constructor to the TSingleton class called GetInstance, then you will get the following result.

MySingleton := TMySingleton.GetInstance;

So I selected to change the behaviour of the constructors of the TSingleton class. I want the constructor to return a single instance of the object, allways.

In order to make an object singleton, one need to override some functions
of the TObject class:

class function NewInstance: TObject;

This function allocates memory for a new object. It is called each time a client calls any constructor. This function should allocate memory only the first time an object is created, and return this memory at each following call.

procedure FreeInstance;

This function free's the memory allocated for the object. It is called each time a destructor is called. Normaly a singleton object is destroyed in the Finalization of the unit, so override this function and leave it empty.

Example

The example is a two classes I use in some applications, and it includes two classes:

TSingleton - a class that implements the singleton pattern making any decendant classes singletons.

TInterfacedSingleton - The same as TSingleton, only implementing the IUnknown interface (Objects of this class are freed at the Finalization or later if there is another reference to them). This singleton class was usefull at one time, and I thought that it is a nice idea.

How to use the two following classes - Derive a new class from one. If you need any initialization done for you're singleton class, override the Init function. If you need any finalization, override the BeforeDestroy function. To get an instance of the singleton, simply write TMySingletonClass.Create;

Notes

The singelton idea does not require to inherit from one TSingleton base class. The code is just one example, and the implementation is not the pattern. The pattern is the idea itself.

The following example is not thread safe. In order to create a thread safe version, you need to make the following functions thread safe:

TSingleton.NewInstance
TInterfacedSingleton.NewInstance
ClearSingletons


Code

unit uSingleton;

interface

uses
  SysUtils;

type
  TSingleton = class(TObject)
  private
    procedure Dispose;
  protected
    procedure Init; virtual;
    procedure BeforeDestroy; virtual;
  public
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
  end;

  TInterfacedSingleton = class(TInterfacedObject, IUnknown)
  private
    procedure Dispose;
  protected
    procedure Init; virtual;
  public
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

implementation

var
  SingletonHash: TStringList;
  // In my original code I use a true Hash Table, but as delphi does not provide
  // one built it, I replaced it here with a TStringList. It should be easy
  // to replace with a true hash table if you have one.

  { General}

procedure ClearSingletons;
var
  I: Integer;
begin
  // call BeforeDestroy for all singleton objects.
  for I := 0 to SingletonHash.Count - 1 do
  begin
    if SingletonHash.Objects[I] is TSingleton then
    begin
      TSingleton(SingletonHash.Objects[I]).BeforeDestroy;
    end
  end;

  // free all singleton and InterfacedSingleton objects.
  for I := 0 to SingletonHash.Count - 1 do
  begin
    if SingletonHash.Objects[I] is TSingleton then
    begin
      TSingleton(SingletonHash.Objects[I]).Dispose;
    end
    else
      TInterfacedSingleton(SingletonHash.Objects[I])._Release;
  end;
end;

{ TSingleton }

procedure TSingleton.BeforeDestroy;
begin

end;

procedure TSingleton.Dispose;
begin
  inherited FreeInstance;
end;

procedure TSingleton.FreeInstance;
begin
  //
end;

procedure TSingleton.Init;
begin

end;

class function TSingleton.NewInstance: TObject;
var
  Singleton: TSingleton;
begin
  if SingletonHash = nil then
    SingletonHash := TStringList.Create;
  if SingletonHash.IndexOf(Self.ClassName) = -1 then
  begin
    Singleton := TSingleton(inherited NewInstance);
    try
      Singleton.Init;
      SingletonHash.AddObject(Self.ClassName, singleton);
    except
      Singleton.Dispose;
      raise;
    end;
  end;
  Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as
    TSingleton;
end;

{ TInterfacedSingleton }

procedure TInterfacedSingleton.Dispose;
begin
  inherited FreeInstance;
end;

procedure TInterfacedSingleton.FreeInstance;
begin
  //
end;

procedure TInterfacedSingleton.Init;
begin

end;

class function TInterfacedSingleton.NewInstance: TObject;
var
  Singleton: TInterfacedSingleton;
begin
  if SingletonHash = nil then
    SingletonHash := TStringList.Create;
  if SingletonHash.IndexOf(Self.ClassName) = -1 then
  begin
    Singleton := TInterfacedSingleton(inherited NewInstance);
    try
      Singleton.Init;
      SingletonHash.AddObject(Self.ClassName, singleton);
      Singleton._AddRef;
    except
      Singleton.Dispose;
      raise;
    end;
  end;
  Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as
    TInterfacedSingleton;
end;

function TInterfacedSingleton._AddRef: Integer;
begin
  Result := inherited _AddRef;
end;

function TInterfacedSingleton._Release: Integer;
begin
  Result := inherited _Release;
end;

initialization
  SingletonHash := nil;

finalization
  if SingletonHash <> nil then
    ClearSingletons;
  SingletonHash.Free;

end.

Managing MDI forms

Problem/Question/Abstract:

Manage MDI forms. Each form will be visble only once. Form will be created if needed.

Answer:

{

This article describes a base class for your mainform.
(You can inherite from this form or use it as is)

Three new routines are presented. They will enable you to easily
manage MDI forms:
- Only one instance per MDI Class will be activated
- Creation of MDI class will be handled by routines if needed
- Activated MDI class will be focused if needed

}

type
  TMDIClass = class of TForm;

type
  TBaseMainForm = class(TForm)
    {... }
  public
    { Public declarations }
    function ActivateMDIClass(MDIClass: TMDIClass): TForm;
    function GetMDIClassIndex(MDIClass: TMDIClass): Integer;
    function MDIClassIsActive(MDIClass: TMDIClass): Boolean;
    {  ... }
  end;

implementation

{
Use ActivateMDIClass() to activate a mdi child class.
If the class is not created yet, it will be.
The mdi child will be shown on screen and focused.
}

function TBaseMainForm.ActivateMDIClass(MDIClass: TMDIClass): TForm;
var
  i: Integer;

begin
  // Try to find index of MDIClass form in MDI child list
  i := GetMDIClassIndex(MDIClass);

  // if index is not found (-1) then create the form
  if i = -1 then
    Result := MDIClass.Create(Application)
  else
    Result := MDIChildren[i];

  // bring it to front
  Result.Show;
  Result.BringToFront;
end;

{
  Get mdi child index of specified MDIClass.
  Returns -1 if the MDIClass does not exist as a created MDI form
}

function TBaseMainForm.GetMDIClassIndex(
  MDIClass: TMDIClass): Integer;
var
  i: Integer;
begin
  // Default index  -1 =  MDIClass not found
  Result := -1;

  // try to find a MDI child of correct MDIClass class
  for i := 0 to MDIChildCount - 1 do
    if MDIChildren[i].ClassType = MDIClass then
      Result := i;
end;

{
  Returns true is the MDIClass exists as a created MDI form
}

function TBaseMainForm.MDIClassIsActive(
  MDIClass: TMDIClass): Boolean;
begin
  Result := GetMDIClassIndex(MDIClass) <> -1;
end;

Usage Example

Create a mainform, inherited from TBaseMainForm.

Create two mdi forms called TfrmBrainstorm and TfrmReport.
Make sure ...FormStyle=fsMDIChild.
Make sure MDI childs can be closed:

procedure...FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := caFree;
end;

Now use the following code to activate those mdi forms:

procedure TMainForm.OnClick1(Sender: TObject);
begin
  ActivateMDIClass(TfrmBrainstorm);
end;

procedure TMainForm.OnClick2(Sender: TObject);
begin
  ActivateMDIClass(TfrmReport);
end;

Add an extra button to the caption bar of your form

Problem/Question/Abstract:

How to add an extra button to the caption bar of a form.

Answer:



unit TitleButton;

interface

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

type
  TChangedProperty = (cpdown, cpallowallup, cpgroupindex);
type
  TTitleButton = class(Tcomponent)
  private
    fbuttonrect: trect;
    fpressed, ffocused: boolean;
    fbuttoncaption: string;
    fwidth: integer;
    fleft: integer;
    fvisible: boolean;
    fhintshow: boolean;
    fhint: thintwindow;
    fhinttext: string;
    fgroupindex: integer;
    fdown: boolean;
    fallowallup: boolean;
    fparent: Tform;
    fparentwidth: integer;
    ficonwidth: integer;
    fcallinheritedevent: boolean;
    fdefaultwidth: integer;
    fdefaultheight: integer;
    ffont: Tfont;
    ficon: Ticon;
    fborder3d, fborderthickness: integer;
    fbuttondown: tnotifyevent;
    fbuttonmove: tmousemoveevent;
    fbuttonup: tnotifyevent;
    pmsghandler: Twndmethod;
    ppaint: Tnotifyevent;
    presize: tnotifyevent;
    gtmp1, gtmp2, gtmp3: boolean;
    procedure initializevariables;
    procedure IconChange(Sender: tobject);
    procedure setbuttonwidth(awidth: integer);
    procedure setbuttonleft(aleft: integer);
    procedure setbuttoncaption(acaption: string);
    procedure setbuttonfont(afont: tfont);
    procedure setbuttonvisible(avisible: boolean);
    procedure seticon(aicon: ticon);
    procedure setdown(adown: boolean);
    procedure setallowallup(aallowallup: boolean);
    procedure setgroupindex(agroupindex: integer);
    procedure UpdateProperties(achangedproperty: TChangedProperty);
  protected
    procedure messagehandler(var msg: tmessage);
    procedure CaptionPaint(var msg: tmessage);
    procedure CaptionMouseMove(var msg: tmessage);
    procedure CaptionMouseDown(var msg: tmessage);
    procedure CaptionMouseUp(var msg: tmessage);
    procedure CaptionRightMouseDown(var msg: tmessage);
    procedure CaptionDoubleClick(var msg: tmessage);
    procedure CaptionActivate(var msg: tmessage);
    procedure CaptionHitTest(var msg: Tmessage);
    procedure CaptionChange(var msg: Tmessage);
    procedure ParentMouseMove(var msg: tmessage);
    procedure ParentMouseUp(var msg: tmessage);
    procedure ButtonUp(var msg: tmessage);
    procedure ParentPaint(sender: tobject);
    procedure ParentResize(sender: tobject);
    procedure DisplaySettingChange(var msg: tmessage);
    procedure loaded; override;
  public
    constructor create(aowner: tcomponent); override;
    destructor destroy; override;
  published
    property Width: integer read fwidth write setbuttonwidth;
    property Position: integer read fleft write setbuttonleft;
    property Caption: string read fbuttoncaption write setbuttoncaption;
    property Font: Tfont read ffont write SetButtonFont;
    property Icon: Ticon read ficon write seticon;
    property TipText: string read fhinttext write fhinttext;
    property Visible: boolean read fvisible write setbuttonvisible;
    property AllowAllUp: boolean read fallowallup write setallowallup;
    property Down: boolean read fdown write setdown;
    property GroupIndex: integer read fgroupindex write setgroupindex;
    property OnMouseDown: tnotifyevent read fbuttondown write fbuttondown;
    property OnMouseMove: tmousemoveevent read fbuttonmove write fbuttonmove;
    property OnMouseUp: tnotifyevent read fbuttonup write fbuttonup;
  end;

const
  TTB_SETBUTTONUP = WM_USER + 1;
procedure Register;

implementation

constructor TTitleButton.create(aowner: tcomponent);
begin
  inherited;
  fparent := (owner as tform);
  ffont := tfont.create;
  fhint := thintwindow.create(self);
  ficon := ticon.create;
end;

destructor TTitleButton.destroy;
begin
  if assigned(ficon) then
    ficon.free;
  if assigned(ffont) then
    ffont.free;
  if assigned(fhint) then
    fhint.free;
  inherited;
end;

procedure TTitleButton.loaded;
begin
  inherited;
  initializevariables;
end;

procedure TTitleButton.UpdateProperties(achangedproperty: TChangedProperty);
var
  amsg: tmessage;
begin
  amsg.Msg := TTB_SETBUTTONUP;
  amsg.WParam := integer(self);
  amsg.LParamlo := fgroupindex;
  amsg.LParamHi := word(achangedproperty);
  amsg.Result := 0;
  fparent.perform(amsg.msg, amsg.wparam, amsg.lparam);
end;

procedure TTitleButton.initializevariables;
begin
  if assigned(fparent.WindowProc) then
    pmsghandler := fparent.WindowProc;
  fparent.WindowProc := messagehandler;
  if not (csdesigning in componentstate) then
  begin
    if assigned(fparent.onpaint) then
      ppaint := fparent.onpaint;
    if assigned(fparent.onresize) then
      presize := fparent.onresize;
    fparent.onpaint := parentpaint;
    fparent.onresize := parentresize;
  end;
  fparentwidth := fparent.width;
  zeromemory(@fbuttonrect, sizeof(fbuttonrect));
  fpressed := false;
  ffocused := false;
  fhintshow := false;
  ficonwidth := 16;
  ficon.Transparent := true;
  ficon.OnChange := IconChange;
  fhint.Color := clInfoBk;
  fcallinheritedevent := false;
  fdefaultwidth := GetSystemMetrics(SM_CXSIZE);
  if fwidth fwidth := fdefaultwidth;
  fdefaultheight := GetSystemMetrics(SM_CYSIZE);
  fborder3d := GetSystemMetrics(SM_CYEDGE);
  fborderthickness := GetSystemMetrics(SM_CYSIZEFRAME);
  gtmp3 := false;
end;

procedure TTitleButton.IconChange(Sender: tobject);
begin
  parentpaint(fparent);
end;

procedure TTitleButton.messagehandler(var msg: tmessage);
begin
  if csdesigning in componentstate then
  begin
    if msg.Msg = TTB_SETBUTTONUP then
    begin
      ButtonUp(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else
      pmsghandler(msg);
  end
  else
  begin
    if msg.Msg = WM_NCPAINT then
    begin
      CaptionPaint(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCLBUTTONDOWN then
    begin
      CaptionMouseDown(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCMOUSEMOVE then
    begin
      CaptionMouseMove(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCLBUTTONUP then
    begin
      CaptionMouseUp(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCACTIVATE then
    begin
      CaptionActivate(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCHITTEST then
    begin
      CaptionHitTest(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_LBUTTONUP then
    begin
      ParentMouseUp(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_MOUSEMOVE then
    begin
      ParentMouseMove(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCRBUTTONDOWN then
    begin
      CaptionRightMouseDown(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCLBUTTONDBLCLK then
    begin
      CaptionDoubleClick(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_NCLBUTTONDBLCLK then
    begin
      CaptionDoubleClick(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_SETTEXT then
    begin
      CaptionChange(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = WM_SETTINGCHANGE then
    begin
      DisplaySettingChange(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else if msg.Msg = TTB_SETBUTTONUP then
    begin
      ButtonUp(msg);
      if (assigned(pmsghandler)) and (fcallinheritedevent) then
        pmsghandler(msg);
    end
    else
      pmsghandler(msg);
  end;
end;

procedure TTitleButton.CaptionPaint(var msg: tmessage);
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  invalidaterect(fparent.handle, @fbuttonrect, false);
end;

procedure TTitleButton.CaptionMouseMove(var msg: tmessage);
var
  pt: tpoint;
  tmpstate: tshiftstate;
  fhintwidth: integer;
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  gtmp1 := fpressed;
  gtmp2 := ffocused;
  pt.x := msg.LParamLo - fparent.left;
  pt.y := msg.LParamHi - fparent.top;
  if PtInRect(fbuttonrect, pt) then
  begin
    ffocused := true;
    {if (gtmp1<>fpressed) or (gtmp2<>ffocused) then
     begin
      invalidaterect(fparent.handle,@fbuttonrect,false);
      gtmp1:=fpressed;
      gtmp2:=ffocused;
     end;}
    fhintwidth := fhint.Canvas.TextWidth(fhinttext);
    if (fhintshow = false) and (length(trim(fhinttext)) <> 0) then
      fhint.ActivateHint(rect(mouse.cursorpos.x, mouse.cursorpos.y + 10,
        mouse.cursorpos.x + fhintwidth + 7, mouse.cursorpos.y + 25), fhinttext);
    fhintshow := true;
    if assigned(fbuttonmove) then
      fbuttonmove(fparent, tmpstate, pt.x, pt.y);
  end
  else
  begin
    ffocused := false;
    fhint.ReleaseHandle;
    fhintshow := false;
  end;
  fcallinheritedevent := true;
end;

procedure TTitleButton.CaptionMouseDown(var msg: tmessage);
var
  pt: tpoint;
  tmp1: boolean;
  callevent: boolean;
begin
  callevent := false;
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  fhintshow := false;
  fhint.releasehandle;
  if fhintshow = true then
    fhint.ReleaseHandle;
  setforegroundwindow(fparent.handle);
  tmp1 := fpressed;
  pt.x := msg.LParamLo - fparent.left;
  pt.y := msg.LParamhi - fparent.top;
  if ptinrect(fbuttonrect, pt) then
  begin
    gtmp3 := true;
    if fgroupindex = 0 then
    begin
      callevent := true;
    end
    else
    begin
      if not (fdown) then
        if assigned(fbuttondown) then
          fbuttondown(fparent);
    end;
    fpressed := true;
    ffocused := true;
    setcapture(fparent.handle);
  end
  else
  begin
    fpressed := false;
    ffocused := false;
  end;
  if (tmp1 <> fpressed) then
    fcallinheritedevent := false;
  gtmp1 := fpressed;
  gtmp2 := ffocused;
  parentpaint(fparent);
  if (callevent) and assigned(fbuttondown) then
    fbuttondown(fparent);
end;

procedure TTitleButton.CaptionMouseUp(var msg: tmessage);
var
  pt: Tpoint;
  tmp1, tmp2: boolean;
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  releasecapture;
  tmp1 := fpressed;
  tmp2 := ffocused;
  pt.x := msg.LParamLo - fparent.left;
  pt.y := msg.LParamhi - fparent.top;
  if (ptinrect(fbuttonrect, pt)) and (ffocused = true) then
    fpressed := false
  else
    ffocused := false;
  if ((tmp1 <> fpressed) or (tmp2 <> ffocused)) and (fallowallup and fdown) then
    invalidaterect(fparent.handle, @fbuttonrect, true);
  fcallinheritedevent := true;
end;

procedure TTitleButton.CaptionRightMouseDown(var msg: tmessage);
var
  pt: tpoint;
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  fhint.releasehandle;
  pt.x := msg.LParamlo - fparent.left;
  pt.y := msg.LParamHi - fparent.top;
  if not ptinrect(fbuttonrect, pt) then
    fcallinheritedevent := true
  else
    fcallinheritedevent := false;
end;

procedure TTitleButton.CaptionDoubleClick(var msg: tmessage);
var
  pt: tpoint;
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  pt.x := msg.LParamlo - fparent.left;
  pt.y := msg.LParamhi - fparent.top;
  if not (ptinrect(fbuttonrect, pt)) then
    fcallinheritedevent := true
  else
  begin
    fcallinheritedevent := false;
    fparent.perform(WM_NCLBUTTONDOWN, msg.wparam, msg.LParam);
  end;
end;

procedure TTitleButton.CaptionActivate(var msg: tmessage);
begin
  fcallinheritedevent := true;
  if not visible then
    exit;
  invalidaterect(fparent.handle, @fbuttonrect, false);
end;

procedure TTitleButton.CaptionHitTest(var msg: Tmessage);
var
  tmp: boolean;
  pt: tpoint;
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  if fpressed then
  begin
    tmp := ffocused;
    pt.x := msg.LParamlo - fparent.left;
    pt.y := msg.LParamhi - fparent.top;
    if ptinrect(fbuttonrect, pt) then
    begin
      ffocused := true
    end
    else
      ffocused := false;
    if ffocused <> tmp then
      invalidaterect(fparent.handle, @fbuttonrect, false);
  end;
  if ffocused = false then
    fhint.releasehandle;
  gtmp1 := fpressed;
  gtmp2 := ffocused;
  fcallinheritedevent := true;
end;

procedure TTitleButton.CaptionChange(var msg: Tmessage);
begin
  fcallinheritedevent := true;
  if not fvisible then
    exit;
  invalidaterect(fparent.handle, @fbuttonrect, false);
end;

procedure TTitleButton.ButtonUp(var msg: tmessage);
var
  sender: ttitlebutton;
  tmp: boolean;
begin
  tmp := fdown;
  fcallinheritedevent := true;
  sender := (tcomponent(msg.WParam) as ttitlebutton);
  if (sender <> self) and (msg.LParamLo = fgroupindex) then
  begin
    if tchangedproperty(msg.lparamhi) = cpdown then
      fdown := false;
    fallowallup := sender.fallowallup;
    if tmp <> fdown then
      invalidaterect(fparent.handle, @fbuttonrect, false);
  end;
end;

procedure TTitleButton.ParentMouseMove(var msg: tmessage);
var
  pt: tpoint;
  tmppt: tpoint;
  tmprect: trect;
  tmpstate: Tshiftstate;
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  ffocused := false;
  pt.x := msg.lparamlo;
  pt.y := msg.lparamhi - fparent.top;
  tmppt := pt;
  tmppt.x := tmppt.x + 4;
  tmppt.y := 65536 - tmppt.y - fparent.top;
  tmprect := fbuttonrect;
  inflaterect(tmprect, 1, 1);
  if ptinrect(tmprect, tmppt) then
  begin
    ffocused := true;
    if assigned(fbuttonmove) then
      fbuttonmove(fparent, tmpstate, tmppt.x, tmppt.y);
    if (gtmp1 <> fpressed) or (gtmp2 <> ffocused) then // if fpressed then
    begin
      invalidaterect(fparent.handle, @fbuttonrect, false);
      gtmp1 := fpressed;
      gtmp2 := ffocused;
    end;
  end;
  if (gtmp1 <> fpressed) or (gtmp2 <> ffocused) then
  begin
    invalidaterect(fparent.handle, @fbuttonrect, false);
    gtmp1 := fpressed;
    gtmp2 := ffocused;
  end;
  fhintshow := false;
  fhint.releasehandle;
end;

procedure TTitleButton.ParentMouseUp(var msg: tmessage);
var
  pt: tpoint;
  tmp: tpoint;
  tmprect: trect;
  tmpcallevent: boolean;
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  tmpcallevent := false;
  fhint.ReleaseHandle;
  fhintshow := true;
  ReleaseCapture;
  fpressed := false;
  pt.x := msg.lParamlo;
  pt.y := msg.lParamhi - fparent.top;
  tmp := pt;
  tmp.x := tmp.x + 4;
  tmp.y := 65536 - tmp.y;
  tmp.y := tmp.y - fparent.top;
  tmprect := fbuttonrect;
  inflaterect(tmprect, 0, 2);
  if tmp.y < (fparent.top + fparent.Height) then
    pt := tmp;
  if (ptinrect(tmprect, pt)) and (ffocused) and (gtmp3) then
  begin
    if fgroupindex <> 0 then
    begin
      if fallowallup = true then
        fdown := not (fdown)
      else
        fdown := true;
      gtmp3 := false;
      updateproperties(cpdown);
      if not (fdown) then
        tmpcallevent := true;
    end
    else
      tmpcallevent := true;
    parentpaint(fparent);
    if (tmpcallevent = true) and assigned(fbuttonup) then
      fbuttonup(fparent);
  end
  else
    gtmp3 := false;
  fcallinheritedevent := true;
end;

procedure TTitleButton.parentpaint(sender: tobject);
var
  ButtonCanvas: TCanvas;
  textrect: trect;
  iconrect: trect;
  tmpwidth: integer;
begin
  if fvisible = false then
  begin
    if assigned(ppaint) then
      ppaint(sender);
    exit;
  end;
  if not (csdesigning in componentstate) then
  begin
    if fwidth fwidth := fdefaultwidth;
    if fleft = 0 then
      fleft := fwidth + 1;
    fbuttonrect.left := fparent.width - fleft - (3 * fdefaultwidth) - (fborder3d +
      fborderthickness);
    fbuttonrect.right := fbuttonrect.left + fwidth;
    fbuttonrect.top := fborder3d + fborderthickness;
    fbuttonrect.bottom := fbuttonrect.top + fdefaultheight - (2 * fborder3d);
    ButtonCanvas := tcanvas.Create;
    ButtonCanvas.Handle := getwindowdc(fparent.handle);
    fillrect(buttoncanvas.Handle, fbuttonrect, HBRUSH(COLOR_BTNFACE + 1));
    tmpwidth := fdefaultheight - 2;
    iconrect.left := fbuttonrect.left;
    iconrect.top := fbuttonrect.top;
    iconrect.right := iconrect.left + tmpwidth;
    iconrect.bottom := fbuttonrect.top + fdefaultheight - 2 * fborder3d;
    if ficon.handle <> 0 then
      subtractrect(textrect, fbuttonrect, iconrect)
    else
      textrect := fbuttonrect;
    if (ffocused and fpressed) or fdown then
    begin
      drawedge(ButtonCanvas.Handle, fbuttonrect, EDGE_SUNKEN, BF_SOFT or BF_RECT);
      textrect.left := textrect.left + 2;
      textrect.Top := textrect.Top + 1;
      textrect.right := textrect.right - 1;
      iconrect.left := iconrect.left + 3;
      iconrect.top := iconrect.top + 2;
    end;
    if (not (fpressed) or not (ffocused)) and not (fdown) then
    begin
      drawedge(ButtonCanvas.Handle, fbuttonrect, EDGE_RAISED, BF_SOFT or BF_RECT);
      textrect.left := textrect.left + 1;
      textrect.right := textrect.right - 1;
      iconrect.top := iconrect.top + 1;
      iconrect.left := iconrect.left + 2;
    end;
    ButtonCanvas.Brush.Style := bsclear;
    ButtonCanvas.Font.assign(ffont);
    if ficon.Handle <> 0 then
    begin
      drawiconex(buttoncanvas.handle, iconrect.left + 1, iconrect.top + 1,
        ficon.handle, tmpwidth - 5, fdefaultheight - 8, 0, 0, DI_NORMAL);
      if length(trim(fbuttoncaption)) > 0 then
        DrawTextEx(ButtonCanvas.Handle, PChar(fButtonCaption), Length(fbuttoncaption),
          textrect, DT_LEFT or DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or
          DT_PATH_ELLIPSIS or DT_MODIFYSTRING, nil);
    end
    else
      DrawText(ButtonCanvas.Handle, PChar(fButtonCaption), Length(fbuttoncaption),
        textrect, DT_CENTER or DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or
        DT_PATH_ELLIPSIS or DT_MODIFYSTRING);
    ButtonCanvas.Free;
    if assigned(ppaint) then
      ppaint(sender);
  end;
end;

procedure TTitleButton.parentresize(sender: tobject);
begin
  fcallinheritedevent := true;
  if fvisible = false then
  begin
    if assigned(presize) then
      presize(sender);
    exit;
  end;
  parentpaint(sender);
  if assigned(presize) then
    presize(self);
end;

procedure TTitleButton.DisplaySettingChange(var msg: tmessage);
begin
  fcallinheritedevent := true;
  if fvisible = false then
    exit;
  fdefaultwidth := GetSystemMetrics(SM_CXSIZE);
  if fwidth fwidth := fdefaultwidth;
  fdefaultheight := GetSystemMetrics(SM_CYSIZE);
  fborder3d := GetSystemMetrics(SM_CYEDGE);
  fborderthickness := GetSystemMetrics(SM_CYSIZEFRAME);
  parentpaint(fparent);
  msg.result := 0;
end;

procedure TTitleButton.setbuttonwidth(awidth: integer);
begin
  if awidth > 0 then
    fwidth := awidth
  else
    fwidth := fdefaultwidth;
  parentpaint(fparent);
end;

procedure TTitleButton.setbuttonleft(aleft: integer);
begin
  if (aleft fleft := aleft;
    parentpaint(fparent);
end;

procedure TTitleButton.setbuttoncaption(acaption: string);
begin
  fbuttoncaption := acaption;
  parentpaint(fparent);
end;

procedure TTitleButton.setbuttonfont(afont: tfont);
begin
  ffont.assign(afont);
  parentpaint(fparent);
end;

procedure TTitleButton.seticon(aicon: ticon);
begin
  ficon.assign(aicon);
  parentpaint(fparent);
end;

procedure TTitleButton.setbuttonvisible(avisible: boolean);
begin
  fvisible := avisible;
  fparent.perform(WM_NCACTIVATE, integer(true), 0);
end;

procedure TTitleButton.setdown(adown: boolean);
var
  tmp: boolean;
begin
  tmp := fdown;
  if csloading in componentstate then
    fdown := adown
  else
  begin
    if fdown <> adown then
    begin
      if fgroupindex = 0 then
        fdown := false
      else
      begin
        if fallowallup = true then
          fdown := adown
        else
          fdown := true;
      end;
    end;
  end;
  if tmp <> fdown then
    updateproperties(cpdown);

end;

procedure TTitleButton.setallowallup(aallowallup: boolean);
var
  tmp: boolean;
begin
  fcallinheritedevent := true;
  tmp := fallowallup;
  if csloading in componentstate then
    fallowallup := aallowallup
  else
  begin
    if fgroupindex <> 0 then
      fallowallup := aallowallup;
    if tmp <> fallowallup then
      updateproperties(cpallowallup);
  end;
end;

procedure TTitleButton.setgroupindex(agroupindex: integer);
var
  tmp: integer;
begin
  tmp := fgroupindex;
  if csloading in componentstate then
    fgroupindex := agroupindex
  else
  begin
    if agroupindex >= 65535 then
      agroupindex := 0;
    if (agroupindex >= 0) then
      fgroupindex := agroupindex;
    if fgroupindex = 0 then
    begin
      fallowallup := false;
      fdown := false;
    end;
    if tmp <> fgroupindex then
      updateproperties(cpgroupindex);
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TTitleButton]);
end;

end.