unit SubClasser;
{ Component that will subclass WindowProc of all TControl components
  placed on the same Form, i.e. same new functionality can be implemented
  to all controls without any need to modify their source code.

  - the default subclass procedure enables dragging of the controls on the form
    if Ctrl+Shift are holded down.
  - SubClasser.SubClassMode must be set smOn (default=smOff)
  - SubClasser.SubClass method must be called if the component is not placed on
    the form at desing time (SubClass is normally called from Loaded method) }

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Clipbrd, ComCtrls, Buttons, ExtCtrls
  {$IFDEF DESIGNINT}
  ,DsgnIntf
  {$ENDIF}
  ;
  {winutl}

type
  TSubClassMode = (smOff, smOnce, smOn);
    { smOff  - no actions triggered in subclassed procedure,
      smOnce - the subclassed action will take place just once, then
               the subClassMode will be switched Off
      smOn   - the subclassed method is active all the time (until switched
               off explicitely
    }
  TSubClassAction = (saMove, saSize);
  TSubClassActions = set of TSubClassAction;

  TSubClasser = class;
  TMessageEvent = Procedure(Control : TControl) of object;

  TSubClassItem = class(TCollectionItem)
  private
    FOldWndMethod : TWndMethod;{forms}
    FControl : TControl;
    FBorderColor,FBackColor : TColor;
    FWidth,FHeight,FBorderWidth : Integer;
    FSubClassActions: TSubClassActions;
    FTest : Boolean;
    FEnabled: boolean;
    Procedure SetControl(value : TControl);
    Procedure SubClassWndProc(var Message: TMessage);
      Procedure OpenMessage(var Message: TMessage);
      procedure PerformMoveSize(var Message: TWMMouse);
    Procedure SetTest(b : boolean);
    function GetSubClasser: TSubClasser;
    property SubClasser: TSubClasser read GetSubClasser;
  Public
    Constructor Create(Collection : TCollection); override;
    Procedure Assign(Source : TPersistent); override;
    Destructor Destroy; override;
    function GetDisplayName: string; override;
  Published
    property Control : TControl read FControl write SetControl;
    Property BackColor : TColor read FBackColor write FBackColor;
    Property BorderColor : TColor read FBorderColor write FBorderColor;
    Property BorderWidth : Integer read FBorderWidth write FBorderWidth;
    Property Width : Integer read FWidth write FWidth;
    Property Height : Integer read FHeight write FHeight;
    Property Test : Boolean read FTest write SetTest stored false;
    property SubClassActions: TSubClassActions read FSubClassActions write FSubClassActions;
    property Enabled: boolean read FEnabled write FEnabled;
  end;

  TSubClassCol = class(TCollection)
  private
    FSubClasser : TSubClasser;
    Function GetItem(index : integer): TSubClassItem;
    Procedure SetItem(index : integer; Value: TSubClassItem);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(item : TCollectionItem); override;
  public
    Constructor Create(SubClasser : TSubClasser);
    Function Add : TSubClassItem;
    Property Items[Index : Integer]: TSubClassItem read GetItem write SetItem; default;
  end;

  TSubClasser = class(TComponent)
  Private
    FSubClassCol: TSubClassCol;
    FSubClassMode: TSubClassMode;
    FEnabled : Boolean;
    FMessageOpen,FMessageClose : TMessageEvent;
    FSubClassActions: TSubClassActions;
    FNoShiftKeys: boolean;
    Procedure SetSubClassCol(Value : TSubClassCol);
    Procedure SetSubClassMode(AMode: TSubClassMode);
  protected
    procedure Loaded;override;
    procedure AddControl(c: TControl);
    procedure RemoveControl(c: TControl);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  Public
    constructor Create(AOwner : TComponent); override;
    Destructor Destroy; override;
    procedure SubClass;
      { called automatically if used as component placed on a form (in Loaded method) }
    function FindItem(AControl: TControl; var AItem: TSubClassItem):boolean;
    procedure ControlEnable(AControl: TControl; OnOff: boolean);
    {v0.31}
    procedure EnableClass(AClass: TClass; OnOff: boolean);
    {/v0.31}
  Published       {tbits}
    property Items : TSubClassCol read FSubClassCol Write SetSubClassCol;
    Property SubClassMode : TSubClassMode read FSubClassMode write SetSubClassMode {stored false};
    property OnMessageOpen : TMessageEvent read FMessageOpen write FMessageOpen;
    property OnMessageClose : TMessageEvent read FMessageClose write FMessageClose;
    Property Enabled : Boolean read FEnabled write FEnabled;
    property SubClassActions: TSubClassActions read FSubClassActions write FSubClassActions;
    {v0.31}
    property NoShiftKeys: boolean read FNoShiftKeys write FNoShiftKeys;
    {/v0.31}
  end;

  {$IFDEF DESIGNINT}
  TSubClasserEditor = class(TComponentEditor)
  Public
    Procedure ExecuteVerb(index : Integer); override;
    Function GetVerb(Index : Integer) : string; override;
    Function GetVerbCount : Integer; override;
  end;
  {$ENDIF}

procedure Register;

implementation
{ $R *.DFM}

procedure Register;
begin
  {$IFDEF DESIGNINT}
  RegisterComponentEditor(TSubClasser, TSubClasserEditor);
  {$ENDIF}
  RegisterComponents('NonVis', [TSubClasser]);
end;

function TSubClassItem.GetDisplayName: string;
begin
  if Control = nil then
    Result := 'Unassigned'
  else if Control.Name <> '' then
    Result := Control.Name
  else
    Result := inherited GetDisplayName;{'Noname'}
end;

procedure TSubClassItem.SetTest(b: boolean);
var m:TMessage;
begin
  fillchar(m, sizeof(m),0);
  if Assigned(FControl) then
    OpenMessage(m);
  FTest := false;
end;
{
procedure TSubClassItem.SetPaste(Value: Boolean);
var h: thandle; p: pchar; C: integer;
begin
 ClipBoard.Open;
 try
  c:=RegisterClipboardFormat(pchar(CF_RTF));
  H := Clipboard.GetAsHandle(C);
  p := GlobalLock(h);
  FRTF:= StrPas(p);
  GlobalUnlock(h);
 finally
  Clipboard.Close;
  FPaste:=false;
 end;
end;
}

procedure TSubClassItem.SetControl(Value: TControl);
var
  a: integer;
  F: boolean;
begin
  if Assigned(Value) then begin
    f := false;
    For a := 0 to Collection.Count-1 do begin
      if Assigned(TSubClassItem(Collection.Items[a]).FControl) and
        (TSubClassItem(Collection.Items[a]).FControl{.Name} = Value{.name})
      then
        f := true;
    end;
    if not f then begin
      if Assigned(FOldWndMethod) then begin
        if Assigned(FControl) then begin
          FControl.WindowProc := FOldWndMethod;
        end;
      end;
      FControl := Value;
      FOldWndMethod := FControl.WindowProc;
      FControl.WindowProc := SubClassWndProc;
    end else begin
      FControl := nil;
      FOldWndMethod := nil;
      raise Exception.Create('Control already linked!');
    end;
  end else begin
    if Assigned(FOldWndMethod) then begin
      if Assigned(FControl) then begin
        FControl.WindowProc := FOldWndMethod;
      end;
    end;
    FOldWndMethod := nil;
    FControl := nil;
  end;
end;

procedure TSubClassItem.PerformMoveSize(var Message: TWMMouse);
const
  SC_DragMove = $F012;{61458} {winutl}
  SC_SizeRightDown = $F008;
  {
    F001 - size control left
    F002 - size control right
    F003 - size control top
    F004 - size control left top
    F005 - size control top right
    F006 - size control down
    F007 - size control left down
    F008 - size control right down
    F009 - move control
    F00A - nothing
    F00B - size control top
    F00C - mouse up/down size control right edge(left/right)

  TForm.XXXXMousedown handlers can do:
    ReleaseCapture;
    XXXX.Perform(WM_SysCommand,SC_DragMove, 0);
  }
const
  XEdgeDist = 3;
  YEdgeDist = 3;
var
  sc:word;
begin
  if Control = nil then
    exit;
  if SubClasser.NoShiftKeys or
     ( ((Message.Keys and MK_CONTROL) <> 0) and ((Message.Keys and MK_SHIFT) <> 0))
  then
  begin
    sc := 0;

    if saSize in SubClasser.SubClassActions then begin
      if Message.xPos < XEdgeDist then begin
        sc := $F001;
      end else if Message.yPos < YEdgeDist then begin
        sc := $F003;
      end else if Message.yPos > (Control.Height - YEdgeDist) then begin
        sc := $F006;
      end else if Message.xPos > (Control.Width - XEdgeDist) then begin
        sc := $F002;
      end;
    end;

    if (sc = 0) and (saMove in SubClasser.SubClassActions) then begin
      sc := SC_DragMove;
    end;

    if sc <> 0 then begin
      Message.Msg := 0;
      ReleaseCapture;
      Control.Perform(WM_SysCommand, sc, 0);
    end;
  end;
end;

function TSubClassItem.GetSubClasser: TSubClasser;
begin
  Result := TSubClassCol(Collection).FSubClasser;
end;

procedure TSubClassItem.OpenMessage(var Message: TMessage);
{var
  ms: TMemoryStream;
  IsLeft, IsTop: Boolean;
  p: integer;
  s: string;}
begin
  if not TSubClassCol(Collection).FSubClasser.Enabled then
    exit;
  {v0.31}
  if not Enabled then
    exit;
  {/v0.31}
  PerformMoveSize(TWMMouse(Message));
{  s := FControl.Name;
  p := pos('_', s);
  if p > 0 then
    s := copy(s, 1, p - 1);
{  Application.MessageJump(s);}
end;
{v0.31}
const testi:integer = 0;
{/v0.31}
procedure TSubClassItem.SubClassWndProc(var Message: TMessage);
var sm: TSubClassMode;
begin
  sm := TSubClassCol(Collection).FSubClasser.SubClassMode;
  If ( (sm <> smOff) and  ( Message.Msg = WM_LBUTTONDOWN ) )
     {or
     ( Message.Msg = WM_Message ) } then
  begin
    {v0.31}
    if fcontrol.name = 'DeviceName' then begin
      testi := 1;
    end;
    {/v0.31}
    if sm <> smOn then
      TSubClassCol(Collection).FSubClasser.SubClassMode := smOff;
    {Message.Msg := 0;}
    OpenMessage(Message);
    if Message.Msg <> 0 then
      FOldWndMethod(Message);
  end else
    FOldWndMethod(Message);
end;

procedure TSubClassItem.Assign(Source: TPersistent);
begin
 if Source is TSubClassItem then begin
   Control := TSubClassItem(Source).Control;
   BorderWidth := TSubClassItem(Source).BorderWidth;
   BackColor := TSubClassItem(Source).BackColor;
   BorderColor := TSubClassItem(Source).BorderColor;
   {RTF:=TSubClassItem(source).RTF;}
   Width := TSubClassItem(Source).Width;
   Height:= TSubClassItem(Source).Height;
 end else
   inherited Assign(Source);
end;

constructor TSubClassItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FBorderWidth := 2;
  FBackColor := clInfoBK;
  FBorderColor := clBlack;
  {FPaste := False;}
  FWidth := Screen.Width div 3;
  FHeight := Screen.height div 3;
  FOldWndMethod := nil;
  FEnabled := true;
end;

destructor TSubClassItem.Destroy;
begin
  if Assigned(FControl) then begin
    FControl.WindowProc := FOldWndMethod;
    FControl := nil;
  end;
  inherited Destroy;
end;

{TSubClasser}
constructor TSubClasser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSubClassMode := smOff;
  FEnabled := true;
  FSubClassActions := [saMove, saSize];
  FSubClassCol := TSubClassCol.Create(Self);
end;

procedure TSubClasser.SubClass;
var
  c: TComponent;
  i: integer;
begin
  if FSubClassCol.Count > 0 then
    exit;
  for i := 0 to Owner.ComponentCount - 1 do begin
    c := Owner.Components[i];
    if c = Self then
      continue;
    if c is TControl then begin
      AddControl(TControl(c));
    end;
  end;
end;

procedure TSubClasser.Loaded;
begin
  if Owner = nil then
    exit;
  if csDesigning in ComponentState then
    exit;
  SubClass;
end;

procedure TSubClasser.AddControl(c: TControl);
var
  h: TSubClassItem;
begin
  h := FSubClassCol.Add;
  h.SubClassActions := SubClassActions;
  h.Control := TControl(c);
end;

procedure TSubClasser.RemoveControl(c: TControl);
var i: TSubClassItem;
begin
  if FSubClassCol = nil then
    exit;
  if FindItem(c, i) then
    i.Control := nil;
end;

function TSubClasser.FindItem(AControl: TControl; var AItem: TSubClassItem):boolean;
var
  i: integer;
begin
  Result := false;
  if FSubClassCol = nil then
     exit;
  for i := 0 to FSubClassCol.Count - 1 do begin
    if FSubClassCol.Items[i].Control = AControl then begin
      AItem := FSubClassCol.Items[i];
      Result := true;
      exit;
    end;
  end;
end;

{v0.31}
procedure TSubClasser.EnableClass(AClass: TClass; OnOff: boolean);
var i: integer;
begin
  for i := 0 to FSubClassCol.Count - 1 do begin
    if FSubClassCol.Items[i].Control is AClass then begin
      FSubClassCol.Items[i].Enabled := OnOff;
    end;
  end;
end;
{/v0.31}

procedure TSubClasser.ControlEnable(AControl: TControl; OnOff: boolean);
var si: TSubClassItem;
begin
  if FindItem(AControl, si) then
    si.Enabled := OnOff;
end;

procedure TSubClasser.Notification(AComponent: TComponent; Operation: TOperation);
begin
  if (Operation = opRemove) then begin
    if AComponent = TComponent(FSubClassCol) then begin
      FSubClassCol.Free;
      FSubClassCol := nil;
    end else begin
      if AComponent is TControl then
        RemoveControl(TControl(AComponent));
    end;
  end else if (Operation = opInsert) then begin
    {if (AComponent is TControl) then begin
      if AComponent.Owner = Owner then
        AddControl(TControl(AComponent));
    end;}
  end;
end;

destructor TSubClasser.Destroy;
begin
  SubClassMode := smOff;
  FSubClassCol.Free;
  inherited Destroy;
end;

procedure TSubClasser.SetSubClassCol(Value: TSubClassCol);
begin
  FSubClassCol.Assign(Value);
end;

procedure TSubClasser.SetSubClassMode(AMode: TSubClassMode);

begin
 If (FSubClassCol.Count > 0) and (AMode <> smOff) then
 begin
   Screen.Cursor := crHelp;{Message;}
   FSubClassMode := AMode;
 end else begin
   Screen.Cursor := crDefault;
   FSubClassMode := smOff;
 end;

end;

{TSubClassCol}
function TSubClassCol.Add: TSubClassItem;
begin
 Result := TSubClassItem(inherited Add);
end;

constructor TSubClassCol.Create(SubClasser: TSubClasser);
begin
  Inherited Create(TSubClassItem);
  FSubClasser := SubClasser;
end;

function TSubClassCol.GetItem(index: integer): TSubClassItem;
begin
  Result := TSubClassItem(inherited GetItem(index));
end;

function TSubClassCol.GetOwner: TPersistent;
begin
  Result := FSubClasser;
end;

procedure TSubClassCol.SetItem(index: integer; Value: TSubClassItem);
begin
  inherited SetItem(index,Value);
end;

procedure TSubClassCol.Update(item: TCollectionItem);
begin
  inherited Update(item);
end;
{/TSubClassCol}

{$IFDEF DESIGNINT}
procedure TSubClasserEditor.ExecuteVerb(index: Integer);
begin
  case Index of
    0 : TSubClasser(Component).SubClassMode := smOnce;
    1 : MessageDlg('SubClasser v1.0'+#13+#10+'by Jindrich Jindrich'
      + #13#10 + 'jindrich@jindrich.com', mtInformation, [mbOK], 0);
  end;
end;

function TSubClasserEditor.GetVerb(Index: Integer): string;
begin
  case index of
    0: Result := 'Test Message';
    1: Result := 'About...';
  end;
end;

function TSubClasserEditor.GetVerbCount: Integer;
begin
  Result := 2;
end;
{$ENDIF}

initialization
  RegisterClasses([TSubClasser]);
end.