home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue28 / subclass / example.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-09-05  |  2.5 KB  |  106 lines
  1. unit example;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   ExtCtrls;
  8.  
  9. type
  10.   Texample = class(TCustomPanel)
  11.   private
  12.    fNewWindowProc : Pointer;  {pointer to our window function}
  13.    fOldWindowProc : Pointer;   {previous window function }
  14.    fTargetHandle : hWnd;
  15.    Procedure NewFormFunction(var msg : tmessage);
  16.   protected
  17.     { Protected declarations }
  18.   public
  19.     constructor create(aOwner: tcomponent); override;
  20.     procedure turnOnSubClassing;
  21.     procedure TurnOffSubClassing;
  22.   published
  23.     property Align;
  24.     property Alignment;
  25.     property BevelInner;
  26.     property BevelOuter;
  27.     property BevelWidth;
  28.     property BorderWidth;
  29.     property BorderStyle;
  30.     property DragCursor;
  31.     property DragMode;
  32.     property Enabled;
  33.     property FullRepaint;
  34.     property Caption;
  35.     property Color;
  36.     property Ctl3D;
  37.     property Font;
  38.     property Locked;
  39.     property ParentColor;
  40.     property ParentCtl3D;
  41.     property ParentFont;
  42.     property ParentShowHint;
  43.     property PopupMenu;
  44.     property ShowHint;
  45.     property TabOrder;
  46.     property TabStop;
  47.     property Visible;
  48.     property OnClick;
  49.     property OnDblClick;
  50.     property OnDragDrop;
  51.     property OnDragOver;
  52.     property OnEndDrag;
  53.     property OnEnter;
  54.     property OnExit;
  55.     property OnMouseDown;
  56.     property OnMouseMove;
  57.     property OnMouseUp;
  58.     property OnResize;
  59.     property OnStartDrag;
  60.   end;
  61.  
  62. procedure Register;
  63.  
  64. implementation
  65.  
  66. constructor Texample.create(aOwner: tcomponent);
  67. begin
  68.   inherited create(aowner);
  69.   bevelInner := bvLowered;
  70.   bevelWidth := 3;
  71.   caption := 'Subclassing off';
  72.   end;
  73.  
  74. procedure Texample.NewFormFunction(var msg : tmessage);
  75. begin
  76.   case msg.msg of
  77.      WM_LBUTTONDOWN : color := clLime;
  78.      WM_RBUTTONDOWN : color := clWhite;
  79.      end;
  80.   msg.Result := CallWindowProc(fOldWindowProc, fTargetHandle, msg.Msg, msg.wParam, msg.LParam);
  81. end;
  82.  
  83. procedure texample.turnOnSubClassing;
  84. begin
  85.    fTargetHandle := parent.handle;
  86.    fNewWindowProc := MakeObjectInstance(NewFormFunction);
  87.    fOldWindowProc := Pointer(SetWindowLong(fTargetHandle, GWL_WNDPROC, LongInt(fNewWindowProc)));
  88.    caption := 'Subclassing on';
  89. end;
  90.  
  91. procedure tExample.TurnOffSubClassing;
  92. begin
  93.    SetWindowLong(fTargetHandle, GWL_WNDPROC, longint(fOldWindowProc));
  94.    FreeObjectInstance(fNewWindowProc);
  95.    caption := 'Subclassing off';
  96.    color := clBtnFace;
  97. end;
  98.  
  99.  
  100. procedure Register;
  101. begin
  102.   RegisterComponents('Samples', [Texample]);
  103. end;
  104.  
  105. end.
  106.