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.

Using class methods to detect Memory-Leaks

Problem/Question/Abstract:

When you dinamically create objects at runtime, you need to check that you free those objects too. Class methods can help in the process.

Answer:

Class Methods aply to the class level, in other words you don�t need an instance to call the method

I wish we could define class objects as well, but they doesn�t exist in Object Pascal, so we will do a trick, we are going to define a variable in the implementation section of the unit, this variable will hold the number of instances the class will have in a moment in time. Object Oriented purist might claim about it, but it works, nobody is perfect (not even Delphi!).

For example say you need to create instances of a class named TFoo, so you create the following Unit.

We will define two class procedures: AddInstance(to increse the counter of instances) and ReleaseInstance(to decrese the number of instances), these are called in the constructor and the destructor acordingly. Finally we define a class function NumOfInstances which returns the actual number of instances.

Add a Initilialization and a Finalization section to the Unit, in the Finalization section ask if the number of instances is <> 0, if this is the case you known that you didin�t destroy all the objects that you created.

unit U_Foo;

interface

uses
  Classes, Windows, SysUtils;

type
  TFoo = class
  private
    class procedure AddInstance;
    class procedure ReleaseInstance;
  public
    constructor Create;
    destructor Destroy; override;
    class function NumOfInstances: Integer;
  end;

implementation

var
  TFoo_Instances: Integer = 0;

  { TFoo }

class procedure TFoo.AddInstance;
begin
  Inc(TFoo_Instances);
end; //end of TFoo.AddInstance

constructor TFoo.Create;
begin
  AddInstance;
end; //end of TFoo.Create

destructor TFoo.Destroy;
begin
  ReleaseInstance;
  inherited;
end; //end of TFoo.Destroy

class function TFoo.NumOfInstances: Integer;
begin
  Result := TFoo_Instances;
end; //end of TFoo.NumOfInstances

class procedure TFoo.ReleaseInstance;
begin
  Dec(TFoo_Instances);
end; //end of TFoo.ReleaseInstance

initialization

finalization

  if TFoo_Instances <> 0 then
    MessageBox(0,
      PChar(Format('%d instances of TFoo active', [TFoo_Instances])),
      'Warning', MB_OK or MB_ICONWARNING);

end.

Draw antialiased circles

Problem/Question/Abstract:

How to draw antialiased circles

Answer:

This demo program shows how to draw circles with configurable antialiasing. The DrawCircle and DrawDisk routines are optimized quite well but do not claim to be the fastest solution :) It is a floating point precision implementation. Further optimisation would be possible if an integer approach was chosen (but that would also loose functionality).

unit DrawCirclesMain;

interface

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

type
  TForm1 = class(TForm)
    btnDrawCircle: TButton;
    edBitmapWidth: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    edBitmapHeight: TEdit;
    Label3: TLabel;
    edCenterX: TEdit;
    Label4: TLabel;
    edCenterY: TEdit;
    Label5: TLabel;
    edRadius: TEdit;
    Label6: TLabel;
    edFeather: TEdit;
    cpbColor: TColorPickerButton;
    Label7: TLabel;
    cpbBackgr: TColorPickerButton;
    Label8: TLabel;
    rbDrawCircle: TRadioButton;
    rbDrawDisk: TRadioButton;
    Label9: TLabel;
    edLineWidth: TEdit;
    ScrollBox1: TScrollBox;
    imMain: TImage;
    btnExportBitmap: TButton;
    procedure btnDrawCircleClick(Sender: TObject);
    procedure btnExportBitmapClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

  {Draw a circle on Bitmap - see comments in implementation}
procedure DrawCircle(Bitmap: TBitmap; CenterX, CenterY, Radius, LineWidth, Feather:
  single);

{Draw a disk on Bitmap - see comments in implementation}
procedure DrawDisk(Bitmap: TBitmap; CenterX, CenterY, Radius, Feather: single);

implementation

{$R *.DFM}

procedure DrawDisk(Bitmap: TBitmap; CenterX, CenterY, Radius, Feather: single);

{Draw a disk on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap, and parts outside the disk will get palette index 0, parts inside will get palette index 255, and in the antialiased area (feather), the pixels will get values in between.

Parameters:

Bitmap:
The bitmap to draw on

CenterX, CenterY:
The center of the disk (float precision). Note that [0, 0] would be the center of the first pixel. To draw in the exact middle of a 100x100 bitmap,  use CenterX = 49.5 and CenterY = 49.5

Radius:
The radius of the drawn disk in pixels (float precision)

Feather:
The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2' become 255. Using a value of 0 will yield a bilevel
image.

Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl}

var
  x, y: integer;
  LX, RX, LY, RY: integer;
  Fact: integer;
  RPF2, RMF2: single;
  P: PByteArray;
  SqY, SqDist: single;
  sqX: array of single;
begin
  {Determine some helpful values (singles)}
  RPF2 := sqr(Radius + Feather / 2);
  RMF2 := sqr(Radius - Feather / 2);
  {Determine bounds:}
  LX := Max(floor(CenterX - RPF2), 0);
  RX := Min(ceil(CenterX + RPF2), Bitmap.Width - 1);
  LY := Max(floor(CenterY - RPF2), 0);
  RY := Min(ceil(CenterY + RPF2), Bitmap.Height - 1);
  {Optimization run: find squares of X first}
  SetLength(SqX, RX - LX + 1);
  for x := LX to RX do
    SqX[x - LX] := sqr(x - CenterX);
  {Loop through Y values}
  for y := LY to RY do
  begin
    P := Bitmap.Scanline[y];
    SqY := Sqr(y - CenterY);
    {Loop through X values}
    for x := LX to RX do
    begin
      {Determine squared distance from center for this pixel}
      SqDist := SqY + SqX[x - LX];
      {Inside inner circle? Most often...}
      if sqdist < RMF2 then
      begin
        {Inside the inner circle.. just give the scanline the new color}
        P[x] := 255
      end
      else
      begin
        {Inside outer circle?}
        if sqdist < RPF2 then
        begin
          {We are inbetween the inner and outer bound, now mix the color}
          Fact := round(((Radius - sqrt(sqdist)) * 2 / Feather) * 127.5 + 127.5);
          P[x] := Max(0, Min(Fact, 255)); {just in case limit to [0, 255]}
        end
        else
        begin
          P[x] := 0;
        end;
      end;
    end;
  end;
end;

procedure DrawCircle(Bitmap: TBitmap; CenterX, CenterY, Radius, LineWidth, Feather:
  single);

{Draw a circle on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap, and parts outside the circle will get palette index 0, parts inside will get palette index 255, and in the antialiased area (feather), the pixels will get values inbetween.

Parameters:

Bitmap:
The bitmap to draw on

CenterX, CenterY:
The center of the circle (float precision). Note that [0, 0] would be the center of the first pixel. To draw in the exact middle of a 100x100 bitmap, use CenterX = 49.5 and CenterY = 49.5

Radius:
The radius of the drawn circle in pixels (float precision)

LineWidth:
The line width of the drawn circle in pixels (float precision)

Feather:
The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2' become 255. Using a value of 0 will yield a bilevel image. Note that Feather must be equal or smaller than LineWidth (or it will be adjusted internally)

Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl}

var
  x, y: integer;
  LX, RX, LY, RY: integer;
  Fact: integer;
  ROPF2, ROMF2, RIPF2, RIMF2: single;
  OutRad, InRad: single;
  P: PByteArray;
  SqY, SqDist: single;
  sqX: array of single;
begin
  {Determine some helpful values (singles)}
  OutRad := Radius + LineWidth / 2;
  InRad := Radius - LineWidth / 2;
  ROPF2 := sqr(OutRad + Feather / 2);
  ROMF2 := sqr(OutRad - Feather / 2);
  RIPF2 := sqr(InRad + Feather / 2);
  RIMF2 := sqr(InRad - Feather / 2);
  {Determine bounds:}
  LX := Max(floor(CenterX - ROPF2), 0);
  RX := Min(ceil(CenterX + ROPF2), Bitmap.Width - 1);
  LY := Max(floor(CenterY - ROPF2), 0);
  RY := Min(ceil(CenterY + ROPF2), Bitmap.Height - 1);
  {Checks}
  if Feather > LineWidth then
    Feather := LineWidth;
  {Optimization run: find squares of X first}
  SetLength(SqX, RX - LX + 1);
  for x := LX to RX do
    SqX[x - LX] := sqr(x - CenterX);
  {Loop through Y values}
  for y := LY to RY do
  begin
    P := Bitmap.Scanline[y];
    SqY := Sqr(y - CenterY);
    {Loop through X values}
    for x := LX to RX do
    begin
      {Determine squared distance from center for this pixel}
      SqDist := SqY + SqX[x - LX];
      {Now first check if we're completely inside (most often)}
      if SqDist < RIMF2 then
      begin
        {We're on the disk inside everything}
        P[x] := 0;
      end
      else
      begin
        {Completely outside?}
        if SqDist < ROPF2 then
        begin
          {Inside outer line - feather?}
          if SqDist < ROMF2 then
          begin
            {Check if we're in inside feather area}
            if SqDist < RIPF2 then
            begin
              {We are in the feather area of inner line, now mix the color}
              Fact := round(((sqrt(sqdist) - InRad) * 2 / Feather) * 127.5 + 127.5);
              P[x] := Max(0, Min(Fact, 255)); {just in case limit to [0, 255]}
            end
            else
            begin
              {On the line}
              P[x] := 255;
            end;
          end
          else
          begin
            {We are in the feather area of outer line, now mix the color}
            Fact := round(((OutRad - sqrt(sqdist)) * 2 / Feather) * 127.5 + 127.5);
            P[x] := Max(0, Min(Fact, 255)); {just in case limit to [0, 255]}
          end;
        end
        else
        begin
          {Outside everything}
          P[x] := 0;
        end;
      end;
    end;
  end;
end;

procedure TForm1.btnDrawCircleClick(Sender: TObject);
{Create a 256-color bitmap and call the DrawCircle procedure}
var
  i, y: integer;
  ABitmap: TBitmap;
  pal: PLogPalette;
  hpal: HPALETTE;
  ColRGB, BgrRGB: integer;
  ACenterX, ACenterY,
    ARadius, AFeather,
    ALineWidth: single;
begin
  ABitmap := TBitmap.Create;
  try
    {8 bits per pixel}
    ABitmap.PixelFormat := pf8bit;
    {Set width and height}
    ABitmap.Width := StrToInt(edBitmapWidth.Text);
    ABitmap.Height := StrToInt(edBitmapHeight.Text);
    {Create a gradient palette between foreground and background color}
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    try
      pal.palVersion := $300;
      pal.palNumEntries := 256;
      ColRGB := ColorToRGB(cpbColor.SelectionColor);
      BgrRGB := ColorToRGB(cpbBackgr.SelectionColor);
      for i := 0 to 255 do
      begin
        pal.palPalEntry[i].peRed := round(i / 255 * (ColRGB and $FF) + (255 - i) / 255
          * (BgrRGB and $FF));
        pal.palPalEntry[i].peGreen := round(i / 255 * (ColRGB shr 8 and $FF) +
          (255 - i) / 255 * (BgrRGB shr 8 and $FF));
        pal.palPalEntry[i].peBlue := round(i / 255 * (ColRGB shr 16 and $FF) +
          (255 - i) / 255 * (BgrRGB shr 16 and $FF));
      end;
      hpal := CreatePalette(pal^);
      if hpal <> 0 then
        ABitmap.Palette := hpal;
    finally
      FreeMem(pal);
    end;
    {Fill bitmap with background color}
    for y := 0 to ABitmap.Height - 1 do
      FillChar(ABitmap.Scanline[y]^, ABitmap.Width, 0);
    {Get data from form}
    ACenterX := StrToFloat(edCenterX.Text);
    ACenterY := StrToFloat(edCenterY.Text);
    ARadius := StrToFloat(edRadius.Text);
    ALineWidth := StrToFloat(edLineWidth.Text);
    AFeather := StrToFloat(edFeather.Text);
    {Draw the circle}
    if rbDrawCircle.Checked then
      DrawCircle(ABitmap, ACenterX, ACenterY, ARadius, ALineWidth, AFeather)
    else
      DrawDisk(ABitmap, ACenterX, ACenterY, ARadius, AFeather);
    {Assign to image}
    imMain.Picture.Bitmap.Assign(ABitmap);
    btnExportBitmap.Enabled := True;
  finally
    ABitmap.Free;
  end;
end;

procedure TForm1.btnExportBitmapClick(Sender: TObject);
begin
  with TSaveDialog.Create(nil) do
  begin
    try
      Title := 'Export bitmap';
      Filter := 'Bitmap files (*.bmp)|*.bmp';
      if Execute then
        imMain.Picture.Bitmap.SaveToFile(FileName);
    finally
      Free;
    end;
  end;
end;

end.

Explanation of "Internal Error"

Problem/Question/Abstract:

Occasionally when compiling an application in Delphi compilation will halt with an error message that reads "Internal Error: X1234" (this is just an example). While this error seemingly means very little to the end user there are steps one can take to try and resolve the problem.

Answer:

Let's start with an explanation of the error message. "Internal Error" indicates that the compiler has encountered a condition, other than a syntax error that it cannot successfully process. The information following "Internal Error" is usually one to three characters immediately followed by a number that indicates the file and line number inside the compiler itself where the error occurred. While this information isn't helpful to the enduser it can help Borland track down the problem if/when it is reported.

What to do when you encounter an "Internal Error"

Should you encounter an internal error there are a few steps that you can take to try and resolve the problem.

If the error occurs immediately after you have modified code in the editor go back to the spot where you made your changes and make a note of what was changed.

If you can undo or comment out the change and recompile your application successfully it is possible that the programming construct that you were using previous exposes a problem with the compiler so jump down to step 7. If not try, the next few steps to resolve your problem.

Delete all of the .DCU files associated with your project.

Close your project completely using File | Close All, then reopen your project, this will clear the unit cache maintained in the IDE. Alternatively you can simply close the IDE and restart.

Another options is to try and recompile your application using the Project | Build option so that the compiler will regenerate all of your DCUs.

If the error is still present exit the IDE and try to compile your application using the command line version of the compiler (dcc32.exe) from a command prompt. This will remove the unit caching of the IDE from the picture and could help to resolve the problem.

If the problem still exists go back to the place where you last made modifications to your file and review the code. Typically, most internal errors can be reproduced with only a few lines of code and frequently the code involves syntax or constructs that are rather unusual or unexpected. If this is the case you can try modifying the code to do the same thing in a different way. For example, if you are typecasting a value try declaring a variable of the cast type and do an assignment first.


Like this:

begin
  if Integer(b) = 100 then
    {...}
end;

var
  a: Integer;
begin
  a := b;
  if a = 100 then
    {...}
end;

Here is an example of unexpected code which can be corrected by the developer to resolve the error:

var
  A: Integer;
begin
  if Int64(Int64(A)) = 0 then
end;

In this case the second cast of A to an In64 is unnecessary and removing it allows the compiler the compile successfully.

If the problem seems to be a "while...do" loop try using a "for...do" loop instead. While this is clearly not the best solution it may help you to continue work on your application. If this resolves the problem it does not mean that either "while" loops or "for" loops are broken but more likely the manner in which you've written your code was unexpected.

Another tip is to create a single directory where all of your .DCP files (precompiled package files) are placed. For example create a directory called C:\DCP and under Tools | Enviroment Options select the Library tab and set DCP output directory to C:\DCP. By making this setting it will help to ensure that the .DCP files that the compiler uses are always the most recent version which is particularly useful when you move a package from one directory to another.

Reboot, log off, shut down or turn off the system

Problem/Question/Abstract:

How would I reboot the system and restart my program?

Answer:

Solve 1:

This will reboot, shutdown, etc. It's a wrapper function for the ExitWindowsEx API:

function ExitWin(ExitType: Integer): Boolean;
{ExitType can be any of these values:
EWX_FORCE, EWX_LOGOFF, EWX_POWEROFF, EWX_REBOOT, EWX_SHUTDOWN}

  function GetShutdownPrivilege: Boolean;
  var
    hToken: THandle;
    tkp: TTokenPrivileges;
    retlength: DWORD;
    Newt: TTokenPrivileges;
  begin
    Result := False;
    hToken := GetCurrentProcess();
    if OpenProcessToken(hToken, TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, hToken) then
    begin
      {Get the LUID for shutdown privilege}
      if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
      begin
        tkp.PrivilegeCount := 1; {One privilege to set}
        tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
        {Get shutdown privilege for this process}
        Result := AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(TTokenPrivileges),
          Newt, retlength)
      end;
    end;
  end;

begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    GetShutdownPrivilege;
  if ExitWindowsEx(ExitType, 0) then
  begin
    Result := True;
  end
  else
  begin
    Result := False;
  end;
end;


Solve 2:

procedure QuitWindows(uFlags: UINT; forced: boolean);
{uFlages can be: EWX_LOGOFF, EWX_REBOOT or EWX_SHUTDOWN}
var
  hProcess: THandle;
  hToken: THandle;
  tpAct, tpPrev: TTokenPrivileges;
  wDummy: DWORD;
begin
  hProcess := GetCurrentProcess;
  OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken);
  LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tpAct.Privileges[0].Luid);
  tpPrev := tpAct;
  tpAct.PrivilegeCount := 1;
  tpAct.Privileges[0].Attributes := 2;
  AdjustTokenPrivileges(hToken, false, tpAct, SizeOf(tpPrev), tpPrev, wDummy);
  if forced then
    uFLags := uFlags or EWX_FORCE;
  ExitWindowsEx(uFlags, 0);
end;


Solve 3:

function GetShutdownPrivilege: Boolean;
const
  SHN: PChar = 'SeShutdownPrivilege';
  EMP: PChar = '';
var
  hToken: THandle;
  tkp, p: TTokenPrivileges;
  RetLen: DWORD;
  Err: DWord;
begin
  {Get a token for this process.}
  if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or
    TOKEN_QUERY, hToken) then
  begin
    Result := False; // 'Error: OpenProcessToken:' + IntToStr(GetLastError)
    Exit;
  end;
  {Get the LUID for the shutdown privilege.}
  if not LookupPrivilegeValue(EMP, SHN, tkp.Privileges[0].Luid) then
  begin
    Result := False; // 'Error: LookupPrivilegeValue:' + IntToStr(GetLastError)
    Exit;
  end;
  tkp.PrivilegeCount := 1; {One privilege to set}
  tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
  {Get the shutdown privilege for this process}
  AdjustTokenPrivileges(hToken, False, tkp, SizeOf(TTokenPrivileges), p, RetLen);
  {Cannot test the return value of AdjustTokenPrivileges}
  Err := GetLastError;
  if Err <> ERROR_SUCCESS then
  begin
    { Err = 1300: 'You do not have the right to shut the system down'
    else
      'Error: AdjustTokenPrivileges: ' + IntToStr(Err); }
    Result := False;
    Exit;
  end;
  {Current user have privileges to shutdown the system}
  Result := True;
end;

Usage:

function MyExit(Param1, Param2: LongWord): Boolean;
if Win32Platform = VER_PLATFORM_WIN32_NT then
  GetShutdownPrivilege;
Result := ExitWindowsEx(Param1, Param2)
end;


Solve 4:

A quite common question I see often in discussion groups is how to shutdown/reboot Windows NT. The problem is that the usual API for the task, ExitWindowsEx, doesn't work right away with Windows NT. It's necessary to "ask for permission" before calling ExitWindows NT. This means that a process must have the SE_SHUTDOWN_NAME privilege for rebooting, powering off, or shutting the system, forced or not (using the EWX_FORCE flag).

For those who have taken a look at the Win32 Development Guide, a help file that comes with Delphi, there's a topic that explains how to shut down Windows NT, but that code is in C++. I've translated the code to Delphi, creating a function called ExitWindowsNT.

Calling ExitWindowsNT is just like calling ExitWindowsEx with only the uFlags paramter. The uFlags parameter specifies the type of shutdown. More about this is explained in the topic "ExitWindowsEx" in the Win32 SDK.

All that said, let's go the function itself:

procedure ExitWindowsNT(uFlags: integer);
var
  hToken: THANDLE;
  tkp, tkDumb: TTokenPrivileges;
  DumbInt: integer;
begin
  FillChar(tkp, sizeof(tkp), 0);
  // Get a token for this process
  if not (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES
    or TOKEN_QUERY, hToken)) then
    raise Exception.create('OpenProcessToken failed with code '
      + inttostr(GetLastError));

  // Get the LUID for the Shutdown privilege
  LookupPrivilegeValue(nil, pchar('SeShutdownPrivilege'),
    tkp.Privileges[0].Luid);

  tkp.PrivilegeCount := 1; // one privilege to set
  tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  // Get the shutdown provolege for this process
  AdjustTokenPrivileges(hToken, false, tkp, sizeof(tkDumb), tkDumb, DumbInt);

  // Cannot test the return value of AdjustTokenPrivileges
  if GetLastError <> ERROR_SUCCESS then
    raise Exception.create('AdjustTokenPrivileges failed with code '
      + inttostr(GetLastError));

  // shut down the system and for all applications to close
  if not ExitWindowsEx(uFlags, 0) then
    raise Exception.create('ExitWindowsEx failed with code '
      + inttostr(GetLastError));
end;

A few examples on using the function above are:

ExitWindowsNT(EWX_SHUTDOWN or EWX_FORCE); ---- This will shutdown Windows NT without making questions. All opened applications will be closed and any unsaved data will be lost.

ExitWindowsNT(EWX_REBOOT); ---- This will reboot the system. Applications will be sent the WM_QUERYENDSESSION message so they can stop the process.

For other possible combinations of EWX_FORCE, EWX_REBOOT, EWX_POWEROFF, EWX_LOGOFF, EWX_SHUTDOWN, please refer to the Win32 Development Guide.


Solve 5:

Shut-down system under Win XP:

function DoExitWindows(RebootParam: Longword): boolean;
var
  TTokenHd: THandle;
  TTokenPvg: TTokenPrivileges;
  cbtpPrevious: DWORD;
  rTTokenPvg: TTokenPrivileges;
  pcbtpPreviousRequired: DWORD;
  tpResult: boolean;
const
  cSE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
  begin
    tpResult := OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES
      or TOKEN_QUERY, TTokenHd);
    if tpResult then
    begin
      tpResult := LookupPrivilegeValue(nil, cSE_SHUTDOWN_NAME,
        TTokenPvg.Privileges[0].Luid);
      TTokenPvg.PrivilegeCount := 1;
      TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      cbtpPrevious := SizeOf(rTTokenPvg);
      pcbtpPreviousRequired := 0;
      if tpResult then
        Windows.AdjustTokenPrivileges(TTokenHd, false, TTokenPvg, cbtpPrevious,
          rTTokenPvg, pcbtpPreviousRequired);
    end;
  end;
  Result := ExitWindowsEx(RebootParam, 0);
end;

Used like this:

DoExitWindows(EWX_SHUTDOWN or EWX_FORCE);

SignalDisplay component

Problem/Question/Abstract:

Ever wanted to display audio from a microphone? ever wanted to have the ability to see wave file actual samples like CoolEdit does?

Answer:

The following component allows:

Multiple data series.
Individual control over X axis and Y axis.
Paning
Zoom

and much more....

the original intention was to be able to display wave file samples like CoolEdit does, a lot of times you need to work on the data and doesn't need the graph component to hold a second copy (like in audio analysis software) so we wrote a component that doesn't hold the data but only displays it.

You can download a demo application (with source) that operates like CoolEdit in the sense it shows the actual samples of the wave file and a lot of neat options at: http://www.com-n-sense.com/ftproot/SignalDisplay.zip

(the zip file contains number of components such as: WaveFileParser and SignalDisplay and more...)

{*==============================================================================
          Copyright (C) 2002, All rights reserved, Com-N-Sense Ltd
================================================================================
File: SignalDisplay.pas
Author: Liran Shahar, Com-N-Sense Ltd
Updated: 24/03/2022
Purpose: 2D signal graph display
================================================================================
History:
  24/03/2002, Liran Shahar
  - Axis visible property at design time bug fixed.
  - Axis color property at design time bug fixed.
  - Memory leak fixed (caused by unfreed series objects).
  - Added ClearSeries procedure to clear the graph from all series (i.e data).

  08/03/2002, Liran Shahar
  - Initial release.
==============================================================================*}
unit SignalDisplay;

interface

uses
  Windows, Messages, Sysutils, Classes, Graphics, Controls, Contnrs, Forms, Math,
  SignalTypes;

const
  X_MARGIN = 10;
  Y_MARGIN = 10;
  TICK_MARGIN = 4;
  DEFAULT_WIDTH = 100;
  DEFAULT_HEIGHT = 100;

type
  TcnsBufferType = (btShortint, btByte, btSmallint, btWord, btLongint, btLongword,
    btSingle, btDouble);

  TcnsSignalDisplay = class;

  TcnsSignalDisplayObject = class(TPersistent)
  private
    FVisible: boolean;
    FColor: TColor;
    Parent: TcnsSignalDisplay;
  protected
    procedure SetVisible(AVisible: boolean); virtual;
    procedure SetColor(AColor: TColor); virtual;
    procedure InitInternalVariables; virtual;
    procedure NotifyParent; virtual; abstract;
  public
    constructor Create(AParent: TcnsSignalDisplay); virtual;
    destructor Destroy; override;
  published
    property Visible: boolean read FVisible write SetVisible default true;
    property Color: TColor read FColor write SetColor default clWhite;
  end;

  TcnsAxis = class(TcnsSignalDisplayObject)
  private
    FMin: double;
    FMax: double;
    FTicks: integer;
  protected
    procedure SetTicks(ATicks: integer); virtual;
    procedure InitInternalVariables; override;
    procedure NotifyParent; override;
  public
    procedure SetRange(AMin, AMax: double); virtual;
    procedure DrawOn(Canvas: TCanvas; WorkRect: TRect; bVertical: boolean); virtual;
    property Min: double read FMin;
    property Max: double read FMax;
  published
    property Ticks: integer read FTicks write SetTicks default 0;
  end;

  TcnsSerie = class(TcnsSignalDisplayObject)
  private
    FBufferPtr: pointer;
    FBufferType: TcnsBufferType;
    FBufferSamples: integer;
    FBufferStep: integer;
  protected
    procedure SetBufferPtr(ABufferPtr: pointer); virtual;
    procedure SetBufferType(ABufferType: TcnsBufferType); virtual;
    procedure SetBufferSamples(ABufferSamples: integer); virtual;
    procedure SetBufferStep(ABufferStep: integer); virtual;
    procedure InitInternalVariables; override;
    procedure NotifyParent; override;
    function GetSampleValue(iSample: integer): double; virtual;
  public
    procedure DrawOn(Canvas: TCanvas; WorkRect: TRect); virtual;
    procedure GetMinMax(var dMin, dMax: double); virtual;
    property BufferPtr: pointer read FBufferPtr write SetBufferPtr;
  published
    property BufferType: TcnsBufferType read FBufferType write SetBufferType default
      btByte;
    property BufferSamples: integer read FBufferSamples write SetBufferSamples default
      0;
    property BufferStep: integer read FBufferStep write SetBufferStep default 1;
  end;

  TcnsSignalDisplayMouseState = (gmsNormal, gmsZoom, gmsMove);

  TcnsSignalDisplayDrawState = set of (dsEraseBackground, dsAxises, dsSeries);

  TcnsSignalDisplayZoomKind = (zkFree, zkXAxis, zkYAxis);

  TcnsSignalDisplay = class(TGraphicControl)
  private
    FXAxis: TcnsAxis;
    FYAxis: TcnsAxis;
    FColor: TColor;
    LockCount: integer;
    Series: TObjectList;
    dXRatio: double;
    dYRatio: double;
    BackBuffer: TBitmap;
    MarkerX, MarkerY, StartX, StartY, MoveX, MoveY: integer;
    MouseState: TcnsSignalDisplayMouseState;
    XAxisRect, YAxisRect, DataRect, RubberBandRect: TRect;
    DrawState: TcnsSignalDisplayDrawState;
    ZoomKind: TcnsSignalDisplayZoomKind;
  protected
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure DrawMarker(X, Y: integer); virtual;
    procedure DrawRubberBand(StartX, StartY, EndX, EndY: integer; Kind:
      TcnsSignalDisplayZoomKind); virtual;
    procedure DrawMoveLine(X, Y: integer); virtual;
    procedure CalculateAllRange; virtual;
    procedure CalculateRects; virtual;
    procedure DrawAxises; virtual;
    procedure DrawSeries; virtual;
    procedure Paint; override;
    procedure Loaded; override;
    function GetSerie(Index: integer): TcnsSerie; virtual;
    procedure SetColor(AColor: TColor); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Lock; virtual;
    procedure Unlock; virtual;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); override;
    function AddSerie: TcnsSerie; virtual;
    function RemoveSerie(Serie: TcnsSerie): boolean; virtual;
    procedure ClearSeries; virtual;
    procedure MouseToWorld(Mx, My: integer; var Wx, Wy: double); virtual;
    procedure WorldToMouse(Wx, Wy: double; var Mx, My: integer); virtual;
    procedure Redraw(NewDrawState: TcnsSignalDisplayDrawState = []); virtual;
    procedure DrawLine(X1, Y1, X2, Y2: double; Color: TColor); virtual;
    property Serie[Index: integer]: TcnsSerie read GetSerie;
  published
    property XAxis: TcnsAxis read FXAxis write FXAxis;
    property YAxis: TcnsAxis read FYAxis write FYAxis;
    property Color: TColor read FColor write SetColor;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Com-N-Sense', [TcnsSignalDisplay]);
end;

//=============================================================================
// TcnsSignalDisplayObject
//=============================================================================

constructor TcnsSignalDisplayObject.Create(AParent: TcnsSignalDisplay);
begin
  inherited Create;
  Parent := AParent;
  InitInternalVariables;
end;

destructor TcnsSignalDisplayObject.Destroy;
begin
  inherited Destroy;
end;

procedure TcnsSignalDisplayObject.SetVisible(AVisible: boolean);
begin
  if AVisible <> FVisible then
  begin
    FVisible := AVisible;
    NotifyParent;
  end; // if
end;

procedure TcnsSignalDisplayObject.SetColor(AColor: TColor);
begin
  if AColor <> FColor then
  begin
    FColor := AColor;
    NotifyParent;
  end; // if
end;

procedure TcnsSignalDisplayObject.InitInternalVariables;
begin
  FVisible := true;
  FColor := clWhite;
end;

//=============================================================================
// TcnsAxis
//=============================================================================

procedure TcnsAxis.SetTicks(ATicks: integer);
begin
  if ATicks <> FTicks then
  begin
    FTicks := ATicks;
    NotifyParent;
  end; // if
end;

procedure TcnsAxis.InitInternalVariables;
begin
  inherited InitInternalVariables;
  FMin := 0.0;
  FMax := 0.0;
  FTicks := 0;
end;

procedure TcnsAxis.NotifyParent;
begin
  Parent.Redraw([dsEraseBackground, dsAxises]);
end;

procedure TcnsAxis.SetRange(AMin, AMax: double);
begin
  if (AMin <> FMin) or (AMax <> FMax) then
  begin
    FMin := AMin;
    FMax := AMax;
    Parent.Redraw([dsEraseBackground, dsAxises, dsSeries]);
  end; // if
end;

procedure TcnsAxis.DrawOn(Canvas: TCanvas; WorkRect: TRect; bVertical: boolean);
var
  iTextWidth, iTextHeight, iLoop, iPos, iTicks: integer;
  sText: AnsiString;
  dTickDelta, dRangeDelta: double;
begin
  iTextHeight := Canvas.TextHeight('0123456789');
  Canvas.Font.Color := FColor;
  Canvas.Pen.Color := FColor;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  Canvas.Pen.Mode := pmCopy;
  if not IsRectEmpty(WorkRect) then
    with WorkRect do
    begin
      Canvas.Brush.Style := bsSolid;
      Canvas.Brush.Color := Parent.Color;
      Canvas.FillRect(WorkRect);
      Canvas.Brush.Style := bsClear;
      if bVertical then
      begin
        sText := format('%f', [FMax]);
        Canvas.TextRect(WorkRect, Left + TICK_MARGIN, Top, sText);
        sText := format('%f', [FMin]);
        Canvas.TextRect(WorkRect, Left + TICK_MARGIN, Bottom - iTextHeight, sText);
        iTicks := FTicks;
        if iTicks > 0 then
        begin
          dTickDelta := (Bottom - Top + 1) / (iTicks + 1);
          dRangeDelta := (FMax - FMin) / (iTicks + 1);
          for iLoop := 1 to Ticks do
          begin
            iPos := Bottom - trunc(dTickDelta * iLoop);
            Canvas.Polyline([Point(Left, iPos), Point(Left + TICK_MARGIN, iPos)]);
            sText := format('%f', [FMin + iLoop * dRangeDelta]);
            Canvas.TextRect(WorkRect, Left + TICK_MARGIN, iPos - iTextHeight shr 1,
              sText);
          end; // for
        end; // if
        Canvas.Polyline([Point(Right, Top), Point(Left, Top), Point(Left, Bottom),
          Point(Right, Bottom)]);
      end
      else
      begin
        sText := format('%f', [FMin]);
        Canvas.TextRect(WorkRect, Left + 1, Top + TICK_MARGIN, sText);
        sText := format('%f', [FMax]);
        iTextWidth := Canvas.TextWidth(sText);
        Canvas.TextRect(WorkRect, Right - iTextWidth - 1, Top + TICK_MARGIN, sText);
        iTicks := FTicks;
        if iTicks > 0 then
        begin
          dTickDelta := (Right - Left + 1) / (iTicks + 1);
          dRangeDelta := (FMax - FMin) / (iTicks + 1);
          for iLoop := 1 to Ticks do
          begin
            iPos := Left + trunc(dTickDelta * iLoop);
            Canvas.Polyline([Point(iPos, Top), Point(iPos, Top + TICK_MARGIN)]);
            sText := format('%f', [FMin + iLoop * dRangeDelta]);
            iTextWidth := Canvas.TextWidth(sText);
            Canvas.TextRect(WorkRect, iPos - iTextWidth shr 1, Top + TICK_MARGIN,
              sText);
          end; // for
        end; // if
        Canvas.Polyline([Point(Left, Bottom), Point(Left, Top), Point(Right, Top),
          Point(Right, Bottom)]);
      end; // if/else
    end; // with
end;

//=============================================================================
// TcnsSerie
//=============================================================================

procedure TcnsSerie.SetBufferPtr(ABufferPtr: pointer);
begin
  if ABufferPtr <> FBufferPtr then
  begin
    FBufferPtr := ABufferPtr;
    NotifyParent;
  end; // if
end;

procedure TcnsSerie.SetBufferType(ABufferType: TcnsBufferType);
begin
  if ABufferType <> FBufferType then
  begin
    FBufferType := ABufferType;
    NotifyParent;
  end; // if
end;

procedure TcnsSerie.SetBufferSamples(ABufferSamples: integer);
begin
  if ABufferSamples <> FBufferSamples then
  begin
    FBufferSamples := ABufferSamples;
    NotifyParent;
  end; // if
end;

procedure TcnsSerie.SetBufferStep(ABufferStep: integer);
begin
  if ABufferStep <> FBufferStep then
  begin
    FBufferStep := ABufferStep;
    NotifyParent;
  end; // if
end;

procedure TcnsSerie.InitInternalVariables;
begin
  inherited InitInternalVariables;
  FBufferPtr := nil;
  FBufferType := btByte;
  FBufferSamples := 0;
  FBufferStep := 1;
end;

procedure TcnsSerie.NotifyParent;
begin
  Parent.Redraw([dsSeries]);
end;

function TcnsSerie.GetSampleValue(iSample: integer): double;
begin
  Result := 0;
  case FBufferType of
    btShortint: Result := PArrayShortint(FBufferPtr)^[iSample];
    btByte: Result := PArrayByte(FBufferPtr)^[iSample];
    btSmallint: Result := PArraySmallint(FBufferPtr)^[iSample];
    btWord: Result := PArrayWord(FBufferPtr)^[iSample];
    btLongint: Result := PArrayLongint(FBufferPtr)^[iSample];
    btLongword: Result := PArrayLongword(FBufferPtr)^[iSample];
    btSingle: Result := PArraySingle(FBufferPtr)^[iSample];
    btDouble: Result := PArrayDouble(FBufferPtr)^[iSample];
  end; // case
end;

procedure TcnsSerie.DrawOn(Canvas: TCanvas; WorkRect: TRect);
var
  ClippingRgn: HRGN;
  bFirst: boolean;
  iLoop, iX, iY, iHeight, iSample, iNumberOfSamples, PrevX, PrevY: integer;
  dValue: double;
begin
  PrevX := -1;
  PrevY := -1;
  ClippingRgn := CreateRectRgnIndirect(WorkRect);
  SelectClipRgn(Canvas.Handle, ClippingRgn);
  iHeight := WorkRect.Bottom - WorkRect.Top + 1;
  Canvas.Pen.Color := FColor;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  bFirst := true;
  with Parent.XAxis do
    iNumberOfSamples := trunc(Max - Min);
  for iLoop := 0 to iNumberOfSamples - 1 do
  begin
    iX := trunc(Parent.dXRatio * iLoop);
    iSample := (iLoop + trunc(Parent.XAxis.Min)) * FBufferStep;
    if (iSample >= 0) and (iSample < FBufferSamples) then
    begin
      dValue := GetSampleValue(iSample);
      iY := iHeight - trunc((dValue - Parent.YAxis.Min) * Parent.dYRatio);
      if bFirst or (iX <> PrevX) or (iY <> PrevY) then
      begin
        if bFirst then
          Canvas.MoveTo(WorkRect.Left + iX, WorkRect.Top + iY)
        else
          Canvas.LineTo(WorkRect.Left + iX, WorkRect.Top + iY);
        bFirst := false;
      end; // if
      PrevX := iX;
      PrevY := iY;
    end; // if
  end; // for
  SelectClipRgn(Canvas.Handle, 0);
  DeleteObject(ClippingRgn);
end;

procedure TcnsSerie.GetMinMax(var dMin, dMax: double);
var
  iSample: integer;
  dSample: double;
begin
  for iSample := 0 to FBufferSamples - 1 do
  begin
    dSample := GetSampleValue(iSample);
    if iSample = 0 then
    begin
      dMin := dSample;
      dMax := dSample;
    end
    else
    begin
      dMin := Min(dMin, dSample);
      dMax := Max(dMax, dSample);
    end; // if/else
  end; // for
end;

//=============================================================================
// TcnsSignalDisplay
//=============================================================================
const
  Y_TICK = 4;
  X_TICK = 4;

  MARKER_X_SIZE = 8;
  MARKER_Y_SIZE = 8;

  MARKER_COLOR = clWhite;
  BAND_COLOR = clWhite;
  MOVE_LINE_COLOR = clWhite;

constructor TcnsSignalDisplay.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FXAxis := TcnsAxis.Create(Self);
  FYAxis := TcnsAxis.Create(Self);
  Width := DEFAULT_WIDTH;
  Height := DEFAULT_HEIGHT;
  LockCount := 0;
  Series := TObjectList.Create;
  Series.OwnsObjects := true;
  MarkerX := -1;
  MarkerY := -1;
  MoveX := -1;
  MoveY := -1;
  MouseState := gmsNormal;
end;

destructor TcnsSignalDisplay.Destroy;
begin
  FreeAndNil(FXAxis);
  FreeAndNil(FYAxis);
  FreeAndNil(Series);
  inherited Destroy;
end;

procedure TcnsSignalDisplay.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  MouseState := gmsNormal;
end;

procedure TcnsSignalDisplay.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  DrawMarker(-1, -1);
end;

procedure TcnsSignalDisplay.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
var
  WorldRect: TRect;
begin
  WorldRect.TopLeft := ClientToScreen(DataRect.TopLeft);
  WorldRect.BottomRight := ClientToScreen(DataRect.BottomRight);
  if PtInRect(DataRect, Point(X, Y)) then
  begin
    if (Button = mbLeft) then
    begin
      MouseState := gmsZoom;
      if ssShift in Shift then
        ZoomKind := zkYAxis
      else if ssCtrl in Shift then
        ZoomKind := zkXAxis
      else
        ZoomKind := zkFree;
      StartX := X;
      StartY := Y;
      ClipCursor(@WorldRect);
    end
    else if (Button = mbRight) then
    begin
      MouseState := gmsMove;
      StartX := X;
      StartY := Y;
      ClipCursor(@WorldRect);
    end;
  end; // if
  inherited;
end;

procedure TcnsSignalDisplay.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  case MouseState of
    gmsNormal:
      if PtInRect(DataRect, Point(X, Y)) then
      begin
        Cursor := crNone;
        DrawMarker(X, Y)
      end
      else
      begin
        DrawMarker(-1, -1);
        Cursor := crDefault;
      end; // if
    gmsZoom:
      begin
        DrawMarker(X, Y);
        DrawRubberBand(StartX, StartY, X, Y, ZoomKind);
      end;
    gmsMove:
      begin
        DrawMoveLine(X, Y);
        DrawMarker(X, Y);
      end;
  end; // case
  inherited;
end;

procedure TcnsSignalDisplay.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
var
  dXMin, dXMax, dYMin, dYMax: double;
begin
  DrawMarker(-1, -1);
  case MouseState of
    gmsNormal:
      if Button = mbMiddle then
      begin
        CalculateAllRange;
      end; // if
    gmsZoom:
      begin
        with RubberBandRect.TopLeft do
          MouseToWorld(X, Y, dXMin, dYMax);
        with RubberBandRect.BottomRight do
          MouseToWorld(X, Y, dXMax, dYMin);
        DrawRubberBand(0, 0, 0, 0, ZoomKind);
        MouseState := gmsNormal;
        Lock;
        if ZoomKind in [zkFree, zkXAxis] then
          FXAxis.SetRange(dXMin, dXMax);
        if ZoomKind in [zkFree, zkYAxis] then
          FYAxis.SetRange(dYMin, dYMax);
        Unlock;
        ClipCursor(nil);
      end;
    gmsMove:
      begin
        Lock;
        if dXRatio <> 0 then
          with FXAxis do
            SetRange(Min - (X - StartX) / dXRatio, Max - (X - StartX) / dXRatio);
        if dYRatio <> 0 then
          with FYAxis do
            SetRange(Min + (Y - StartY) / dYRatio, Max + (Y - StartY) / dYRatio);
        MouseState := gmsNormal;
        DrawMoveLine(-1, -1);
        Unlock;
        ClipCursor(nil);
      end;
  end; // case
  DrawMarker(X, Y);
  inherited;
end;

procedure TcnsSignalDisplay.DrawMarker(X, Y: integer);
begin
  Canvas.Pen.Mode := pmXor;
  Canvas.Pen.Color := MARKER_COLOR;
  Canvas.Pen.Width := 1;
  if (MarkerX <> -1) and (MarkerY <> -1) then
  begin
    Canvas.MoveTo(MarkerX, MarkerY - MARKER_Y_SIZE);
    Canvas.LineTo(MarkerX, MarkerY + MARKER_Y_SIZE);
    Canvas.MoveTo(MarkerX - MARKER_X_SIZE, MarkerY);
    Canvas.LineTo(MarkerX + MARKER_X_SIZE, MarkerY);
    MarkerX := -1;
    MarkerY := -1;
  end; // if
  if (X <> -1) and (Y <> -1) then
  begin
    MarkerX := X;
    MarkerY := Y;
    Canvas.MoveTo(MarkerX, MarkerY - MARKER_Y_SIZE);
    Canvas.LineTo(MarkerX, MarkerY + MARKER_Y_SIZE);
    Canvas.MoveTo(MarkerX - MARKER_X_SIZE, MarkerY);
    Canvas.LineTo(MarkerX + MARKER_X_SIZE, MarkerY);
  end; // if
end;

procedure TcnsSignalDisplay.DrawRubberBand(StartX, StartY, EndX, EndY: integer; Kind:
  TcnsSignalDisplayZoomKind);
begin
  Canvas.Pen.Mode := pmXor;
  Canvas.Pen.Color := BAND_COLOR;
  Canvas.Pen.Width := 1;
  Canvas.Pen.Style := psDot;
  if not IsRectEmpty(RubberBandRect) then
    with RubberBandRect do
      Canvas.Polyline([Point(Left, Top), Point(Right, Top), Point(Right, Bottom),
        Point(Left, Bottom), Point(Left, Top)]);
  case Kind of
    zkYAxis:
      begin
        StartX := DataRect.Left;
        EndX := DataRect.Right - 1;
      end;
    zkXAxis:
      begin
        StartY := DataRect.Top;
        EndY := DataRect.Bottom - 1;
      end;
  end;
  RubberBandRect.Left := Min(StartX, EndX);
  RubberBandRect.Top := Min(StartY, EndY);
  RubberBandRect.Right := Max(StartX, EndX);
  RubberBandRect.Bottom := Max(StartY, EndY);
  if not IsRectEmpty(RubberBandRect) then
    with RubberBandRect do
      Canvas.Polyline([Point(Left, Top), Point(Right, Top), Point(Right, Bottom),
        Point(Left, Bottom), Point(Left, Top)]);
end;

procedure TcnsSignalDisplay.DrawMoveLine(X, Y: integer);
begin
  Canvas.Pen.Mode := pmXor;
  Canvas.Pen.Color := MOVE_LINE_COLOR;
  Canvas.Pen.Width := 1;
  Canvas.Pen.Style := psDash;
  if (MoveX <> -1) and (MoveY <> -1) then
  begin
    Canvas.MoveTo(StartX, StartY);
    Canvas.LineTo(MoveX, MoveY);
    MoveX := -1;
    MoveY := -1;
  end; // if
  if (X <> -1) and (Y <> -1) then
  begin
    Canvas.MoveTo(StartX, StartY);
    Canvas.LineTo(X, Y);
    MoveX := X;
    MoveY := Y;
  end; // if
end;

procedure TcnsSignalDisplay.CalculateAllRange;
var
  XMin, XMax, YMin, YMax, TmpYMin, TmpYMax: double;
  iLoop: integer;
  Serie: TcnsSerie;
begin
  XMax := 0;
  XMin := 0;
  for iLoop := 0 to Series.Count - 1 do
  begin
    Serie := GetSerie(iLoop);
    if iLoop = 0 then
    begin
      XMax := Serie.BufferSamples;
      Serie.GetMinMax(YMin, YMax);
    end
    else
    begin
      XMax := Max(XMax, Serie.BufferSamples);
      Serie.GetMinMax(TmpYMin, TmpYMax);
      YMin := Min(YMin, TmpYMin);
      YMax := Max(YMax, TmpYMax);
    end; // if/else
  end;
  Lock;
  FXAxis.SetRange(XMin, XMax);
  FYAxis.SetRange(YMin, YMax);
  Unlock;
end;

procedure TcnsSignalDisplay.CalculateRects;
var
  iLeft, iTop, iRight, iBottom, iTextWidth, iTextHeight: integer;
begin
  XAxisRect := Rect(0, 0, 0, 0);
  YAxisRect := Rect(0, 0, 0, 0);
  iLeft := ClientRect.Left + X_MARGIN;
  iTop := ClientRect.Top + Y_MARGIN;
  iRight := ClientRect.Right - X_MARGIN - TICK_MARGIN;
  iBottom := ClientRect.Bottom - Y_MARGIN - TICK_MARGIN;
  iTextWidth := Math.Max(Canvas.TextWidth(format('%fW', [FYAxis.Min])),
    Canvas.TextWidth(format('%fW', [FYAxis.Max])));
  iTextHeight := BackBuffer.Canvas.TextHeight('0123456789');
  DataRect := Rect(iLeft, iTop, iRight, iBottom);
  if FXAxis.Visible then
    DataRect.Bottom := iBottom - iTextHeight;
  if FYAxis.Visible then
    DataRect.Right := iRight - iTextWidth;
  with DataRect do
  begin
    if FXAxis.Visible then
      XAxisRect := Rect(iLeft, Bottom + 1, Right, iBottom + TICK_MARGIN);
    if FYAxis.Visible then
      YAxisRect := Rect(Right + 1, Top, iRight + TICK_MARGIN, Bottom);
  end; // with
  dXRatio := 0;
  dYRatio := 0;
  with FXAxis do
    dXRatio := (DataRect.Right - DataRect.Left + 1) / (Max - Min + 1);
  with FYAxis do
    dYRatio := (DataRect.Bottom - DataRect.Top + 1) / (Max - Min + 1);
end;

procedure TcnsSignalDisplay.DrawAxises;
begin
  FXAxis.DrawOn(BackBuffer.Canvas, XAxisRect, false);
  FYAxis.DrawOn(BackBuffer.Canvas, YAxisRect, true);
end;

procedure TcnsSignalDisplay.DrawSeries;
var
  iSerie: integer;
  Serie: TcnsSerie;
begin
  BackBuffer.Canvas.Brush.Color := FColor;
  BackBuffer.Canvas.FillRect(DataRect);
  for iSerie := 0 to Series.Count - 1 do
  begin
    Serie := GetSerie(iSerie);
    with Serie do
      if Visible and assigned(BufferPtr) then
        DrawOn(BackBuffer.Canvas, DataRect);
  end; // for
end;

procedure TcnsSignalDisplay.Paint;
begin
  if not assigned(BackBuffer) then
  begin
    BackBuffer := TBitmap.Create;
    BackBuffer.Width := Width;
    BackBuffer.Height := Height;
    BackBuffer.PixelFormat := pf24Bit;
    DrawState := DrawState + [dsEraseBackground, dsAxises, dsSeries];
  end; // if
  if dsEraseBackground in DrawState then
  begin
    BackBuffer.Canvas.Brush.Color := FColor;
    BackBuffer.Canvas.FillRect(ClientRect);
  end; // if
  CalculateRects;
  if dsAxises in DrawState then
    DrawAxises;
  if dsSeries in DrawState then
    DrawSeries;
  Canvas.Draw(0, 0, BackBuffer);
  DrawState := [];
end;

procedure TcnsSignalDisplay.Loaded;
begin
  inherited Loaded;
  FreeAndNil(BackBuffer);
  Redraw([dsEraseBackground, dsAxises, dsSeries]);
end;

function TcnsSignalDisplay.GetSerie(Index: integer): TcnsSerie;
begin
  Result := nil;
  if (Index >= 0) and (Index < Series.Count) then
    Result := TcnsSerie(Series[Index]);
end;

procedure TcnsSignalDisplay.SetColor(AColor: TColor);
begin
  if AColor <> FColor then
  begin
    FColor := AColor;
    Redraw([dsEraseBackground, dsSeries, dsAxises]);
  end; // if
end;

procedure TcnsSignalDisplay.Lock;
begin
  LockCount := LockCount + 1;
end;

procedure TcnsSignalDisplay.Unlock;
begin
  LockCount := LockCount - 1;
  Redraw;
end;

procedure TcnsSignalDisplay.SetBounds(ALeft, ATop, AWidth, AHeight: integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  FreeAndNil(BackBuffer);
end;

function TcnsSignalDisplay.AddSerie: TcnsSerie;
begin
  Result := TcnsSerie.Create(Self);
  Series.Add(Result);
end;

function TcnsSignalDisplay.RemoveSerie(Serie: TcnsSerie): boolean;
var
  iIndex: integer;
begin
  Result := true;
  iIndex := Series.IndexOf(Serie);
  if iIndex > -1 then
  begin
    Series.Delete(iIndex);
    Redraw([dsSeries]);
  end
  else
    Result := false;
end;

procedure TcnsSignalDisplay.ClearSeries;
begin
  Series.Clear;
end;

procedure TcnsSignalDisplay.MouseToWorld(Mx, My: integer; var Wx, Wy: double);
begin
  Wx := 0;
  if dXRatio <> 0 then
    Wx := FXAxis.FMin + (Mx - DataRect.Left) / dXRatio;
  Wy := 0;
  if dYRatio <> 0 then
    Wy := FYAxis.FMax - (My - DataRect.Top) / dYRatio;
end;

procedure TcnsSignalDisplay.WorldToMouse(Wx, Wy: double; var Mx, My: integer);
begin
  Mx := 0;
  My := 0;
  if dXRatio <> 0 then
    Mx := DataRect.Left + trunc((Wx - FXAxis.FMin) * dXRatio);
  if dYRatio <> 0 then
    My := DataRect.Top + trunc((FYAxis.FMax - Wy) * dYRatio);
end;

procedure TcnsSignalDisplay.Redraw(NewDrawState: TcnsSignalDisplayDrawState);
begin
  DrawState := DrawState + NewDrawState;
  if LockCount = 0 then
    Repaint;
end;

procedure TcnsSignalDisplay.DrawLine(X1, Y1, X2, Y2: double; Color: TColor);
var
  iX1, iY1, iX2, iY2: integer;
begin
  WorldToMouse(X1, Y1, iX1, iY1);
  WorldToMouse(X2, Y2, iX2, iY2);
  Canvas.Pen.Color := Color;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Mode := pmCopy;
  Canvas.MoveTo(iX1, iY1);
  Canvas.LineTo(iX2, iY2);
end;

end.