arashi.pas

delphi 不需任何控件

unit Arashi;
{$A-}{$O-}{$H+}{$WARNINGS OFF}{$HINTS OFF}{$M-}

interface
uses
  Windows, Messages;

type
  {Pointer Types}
  PControl = ^TControl;
  PWnd = PControl;
  PForm = ^TForm;
  PHookDialogBase = ^THookDialogBase;

  TBasicControl=(Button, ComboBox, Edit, ListBox, MDIClient, HotKey,
    Progress, StatusBar, TrackBar, UpDown, ReBar, RichEdit, ScrollBar,
    Static, Animate, DateTimePicker, Header, ListView, MonthCal, Pager,
    TabControl, TreeView, Toolbar);

  PMenu = PControl;
  PPopupMenu = PControl;

  {General Types}
  TCallbackInstance = array [1..18] of Byte;
  TFakeRect = record Left, Top, Width, Height:Integer; end;
  TMouseButton =(mbLeft, mbRight, mbMiddle);

  TOnEvent = procedure (Sender: PControl) of object;
  TOnMessage = procedure (Sender:PControl; Msg:TMessage) of object;
  TOnMouse = procedure (Sender:PControl; X, Y: Word; MouseButton:TMouseButton) of object;
  TOnKey = procedure (Sender:PControl; Key:Integer) of object;

  {Object Types}
  TControl = object
  private
    FHandle: HWND;
    FParent: PWnd;
    FOnClose: TOnEvent;
    FOnCreate: TOnEvent;
    FBounds: TRect;
    FRect: TFakeRect;
    FOnMessage: TOnMessage;
    FOnFocus: TOnEvent;
    FOnSysCommand: TOnMessage;
    FOnMove: TOnEvent;
  	OldProc:Pointer;
    FOnContext: TOnEvent;
    FOnMouseDown: TOnMouse;
    FOnMouseMove: TOnMouse;
    FOnMouseHover: TOnEvent;
    FOnMouseUp: TOnMouse;
    FOnMouseLeave: TOnEvent;
    FOnKeyDown: TOnKey;
    FOnDblClick: TOnEvent;
    FOnKeyUp: TOnKey;
    FOnChar: TOnKey;
    FOnClick: TOnEvent;
    procedure SetBound(const Index,Value:Integer);
    function GetText: PChar;
    procedure SetText(const Value: PChar);
  protected
  	IsForm: Boolean;
    FCallbackInstance: TCallbackInstance;
    function WindowProc(hWnd: HWND;uMsg:Cardinal; wParam, lParam: Integer): Integer; stdcall;
  public
    procedure Create(AParent:PWnd);
    procedure SetBounds(ALeft, ATop, AWidth, AHeight:Integer);
  public
    property Parent:PWnd read FParent;
    property Handle:HWND read FHandle;
    property Caption:PChar read GetText write SetText;
    property Text:PChar read GetText write SetText;

    property BoundRect:TRect read FBounds;
    property Left:  Integer index 1 read FRect.Left write SetBound default CW_USEDEFAULT;
    property Top:   Integer index 2 read FRect.Top write SetBound default CW_USEDEFAULT;
    property Width: Integer index 3 read FRect.Width write SetBound default CW_USEDEFAULT;
    property Height:Integer index 4 read FRect.Height write SetBound default CW_USEDEFAULT;

    property OnMessage:TOnMessage read FOnMessage write FOnMessage;
    property OnFocus:TOnEvent read FOnFocus write FOnFocus;
    property OnSysCommand:TOnMessage read FOnSysCommand write FOnSysCommand;
    property OnMoveSize:TOnEvent read FOnMove write FOnMove;
    property OnMouseEnter:TOnEvent read FOnMouseHover write FOnMouseHover;
    property OnMouseExit:TOnEvent read FOnMouseLeave write FOnMouseLeave;
    property OnMouseDown:TOnMouse read FOnMouseDown write FOnMouseDown;
    property OnMouseUp:TOnMouse read FOnMouseUp write FOnMouseUp;
    property OnMouseMove:TOnMouse read FOnMouseMove write FOnMouseMove;
    property OnDblClick:TOnEvent read FOnDblClick write FOnDblClick;
    property OnKeyDown:TOnKey read FOnKeyDown write FOnKeyDown;
    property OnKeyUp:TOnKey read FOnKeyUp write FOnKeyUp;
    property OnChar:TOnKey read FOnChar write FOnChar;
    property OnClick:TOnEvent read FOnClick write FOnClick;
  protected
    property OnCreate:TOnEvent read FOnCreate write FOnCreate;
    property OnClose:TOnEvent read FOnClose write FOnClose;
  end;

  THookDialogBase = object(TControl)
  private
  	hhk:HHOOK;
  protected
    function DoExecute:Boolean ;virtual;
    function HookProc(nCode, wParam, lParam:Integer): LRESULT stdcall;
  public
    function Execute:Boolean;
    property OnCreate;
    property OnClose;
  end;

  TForm = object(TControl)
  public
    procedure Create(hWndParent:HWND; ACaption:PChar);
  end;

  TApplication = object
  public
    procedure Initialize;
    procedure CreateForm(AForm: PForm;ACaption:PChar);
    procedure Run;
  end;

procedure MakeCallbackInstance(var Instance: TCallbackInstance;
  ObjectAddr: Pointer; FunctionAddr: Pointer);
function CreateCtrl(AParent:PWnd; AClassName,ACaption:PChar;
  ID:Integer=0; Style:Cardinal=0):PControl;
function CreateCtrlByType(AParent:PWnd; ControlType:TBasicControl;ACaption:PChar;
  ID:Integer=0; Style:Cardinal=0):PControl;

var
  Application: ^TApplication;
  
implementation
{----------------------------}
{   CallbackCode DASM        }
{----------------------------}
{     MOV EAX, [ESP];        }
{     PUSH EAX;              }
{     MOV EAX, ObjectAddr;   }
{     MOV [ESP+4], EAX;      }
{     JMP FunctionAddr;      }
{----------------------------}
procedure MakeCallbackInstance(var Instance: TCallbackInstance;
  ObjectAddr: Pointer; FunctionAddr: Pointer);
const CallbackCode: TCallbackInstance =
  ($8B,$04,$24,$50,$B8,$00,$00,$00,$00,$89,$44,$24,$04,$E9,$00,$00,$00,$00);
begin
  Instance:=CallbackCode;
  PInteger(@Instance[6])^ := Integer(ObjectAddr);
  PInteger(@Instance[15])^ := Integer(Integer(FunctionAddr) - Integer(@Instance) - 18);
end;

{ TControl }
procedure TControl.Create(AParent:PWnd);
begin
  FParent:=AParent;
  IsForm:=False;
  MakeCallbackInstance(FCallbackInstance, @Self, @TControl.WindowProc);
  Integer(OldProc):=SetWindowLong(FHandle,GWL_WNDPROC,Integer(@FCallbackInstance));
end;

function TControl.GetText: PChar;
begin
  GetMem(Result,255);
  GetWindowText(Handle,Result,255);
end;

procedure TControl.SetBound(const Index, Value: Integer);
begin
  case Index of
    1:FRect.Left:=Value;
    2:FRect.Top:=Value;
    3:FRect.Width:=Value;
    4:FRect.Height:=Value;
  end;
  MoveWindow(FHandle,FRect.Left,FRect.Top,FRect.Width,FRect.Height, True);
  if Assigned(FOnMove) then FOnMove(@Self);
end;

procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight:Integer);
begin
  FRect.Left:=ALeft;    FBounds.Left:=ALeft;
  FRect.Top:=ATop;      FBounds.Top:=ATop;
  FRect.Width:=AWidth;  FBounds.Right:=ALeft+AWidth;
  FRect.Height:=AHeight;FBounds.Right:=ATop+AHeight;
  MoveWindow(FHandle,ALeft,ATop,AWidth,AHeight, True);
end;

procedure TControl.SetText(const Value: PChar);
begin
  SetWindowText(Handle,Value);
end;

function TControl.WindowProc(hWnd: HWND; uMsg:Cardinal; wParam,
  lParam: Integer): Integer;
var Msg:TMessage;
begin
  Msg.Msg:=uMsg;
  Msg.WParam:=wParam;
  Msg.LParam:=lParam;
  case uMsg of
    WM_CREATE:if Assigned (FOnCreate) then FOnCreate(@Self);
    WM_CLOSE, WM_DESTROY:begin
      if Assigned(FOnClose) then FOnClose(@Self);
      PostQuitMessage(0);
    end;
    WM_MOVE, WM_SIZE, WM_MOVING, WM_SIZING: if Assigned(FOnMove) then FOnMove(@Self);
    WM_SYSCOMMAND:if Assigned(FOnSysCommand) then FOnSysCommand(@Self,Msg);
    WM_CONTEXTMENU:begin
    	if Assigned(FOnContext) then FOnContext(@Self);
    end;
    WM_MOUSEHOVER:if Assigned(FOnMouseHover) then FOnMouseHover(@Self);
    WM_MOUSELEAVE:if Assigned(FOnMouseLeave) then FOnMouseLeave(@Self);
    WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN:if Assigned(FOnMouseDown) then
    	FOnMouseDown(@Self,LoWord(lParam),HiWord(lParam),
      TMouseButton((uMsg-WM_LBUTTONDOWN) div 3));
    WM_LBUTTONUP,WM_RBUTTONUP,WM_MBUTTONUP:begin
      if Assigned(FOnMouseUp) then
    	FOnMouseUp(@Self,LoWord(lParam),HiWord(lParam),
      TMouseButton((uMsg-WM_LBUTTONUP) div 3));
      if Assigned(FOnClick) then FOnClick(@Self);
    end;
    WM_MOUSEMOVE:if Assigned(FOnMouseMove) then
      FOnMouseMove(@Self,LoWord(lParam),HiWord(lParam),mbLeft);
    WM_LBUTTONDBLCLK:if Assigned(FOnDblClick) then FOnDblClick(@Self);
    WM_KEYDOWN:if Assigned(FOnKeyDown) then FOnKeyDown(@Self,wParam);
    WM_KEYUP:if Assigned(FOnKeyUp) then FOnKeyUp(@Self,wParam);
    WM_CHAR:if Assigned(FOnChar) then FOnChar(@Self,wParam);
    WM_SETFOCUS:if Assigned(FOnFocus) then FOnFocus(@Self);
  end;
  if Assigned(FOnMessage) then FOnMessage(@Self,Msg);
  if IsForm then
  	Result := DefWindowProc(hWnd, uMsg, WParam, LParam)
  else Result:=CallWindowProc(OldProc,hWnd,uMsg,wParam,lParam);
end;

{ TApplication }
procedure TApplication.CreateForm(AForm: PForm;ACaption:PChar);
begin
  New(AForm);
  AForm.Create(0,ACaption);
end;

procedure TApplication.Initialize;
asm
end;

procedure TApplication.Run;
var Msg:tagMSG;
begin
  while GetMessage(Msg, 0, 0, 0) do
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
end;

{ TForm } 
procedure TForm.Create(hWndParent: HWND;ACaption:PChar);
var
  WindowClass: TWndClass;
begin
	IsForm:=True;
  MakeCallbackInstance(FCallbackInstance, @Self, @TControl.WindowProc);
  WindowClass.Style := CS_HREDRAW or CS_VREDRAW;
  WindowClass.lpfnWndProc := @FCallbackInstance;//@TControl.WindowProc;
  WindowClass.cbClsExtra := 0;
  WindowClass.cbWndExtra := 0;
  WindowClass.hInstance := hInstance;
  WindowClass.hIcon:=0;
  WindowClass.hCursor := 0;
  WindowClass.hbrBackground := COLOR_WINDOW;
  WindowClass.lpszMenuName := nil;
  WindowClass.lpszClassName := 'T';
  RegisterClass(WindowClass);
  FHandle := CreateWindowEx(0,'T',ACaption,
    WS_TILED or WS_VISIBLE or WS_SYSMENU,CW_USEDEFAULT,
    CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,hWndParent,
    0,hInstance,nil);
end;

{ THookDialogBase }
function THookDialogBase.DoExecute: Boolean;
begin

end;

function THookDialogBase.Execute: Boolean;
begin
	IsForm:=True;
  MakeCallbackInstance(FCallbackInstance, @Self, @THookDialogBase.HookProc);
  hhk:=SetWindowsHookEx(WH_CBT,@FCallbackInstance,0, GetCurrentThreadId);
  Result:=DoExecute;
end;

function THookDialogBase.HookProc(nCode, wParam, lParam:Integer): LRESULT;
var Msg:TMessage;
begin
  case nCode of
	  HCBT_MOVESIZE,HCBT_MINMAX:if Assigned(FOnMove) then FOnMove(@Self);
  	HCBT_DESTROYWND:begin
    	if Assigned(FOnClose) then FOnClose(@Self);
    	UnhookWindowsHookEx(hhk);
    end;
	  HCBT_ACTIVATE:begin
    	FHandle:=wParam;
    	GetWindowRect(FHandle,FBounds);
      Left:=FBounds.Left;		Top:=FBounds.Top;
      Width:=FBounds.Right-FBounds.Left;	Height:=FBounds.Right-FBounds.Left;
      FParent.FHandle:=GetWindow(FHandle,GW_OWNER);
    	if Assigned(FOnCreate) then FOnCreate(@Self);
    end;
  	HCBT_SYSCOMMAND:if Assigned(FOnSysCommand) then FOnSysCommand(@Self, Msg);
  	HCBT_SETFOCUS:if Assigned(FOnFocus) then FOnFocus(@Self);
  end;
  if Assigned(FOnMessage) then begin
  	Msg.Msg:=WM_NULL;
    Msg.WParam:=wParam;
    Msg.LParam:=lParam;
    FOnMessage(@Self,Msg);
  end;
  Result:=0;
end;

{ Windows Controls}
function CreateCtrl(AParent:PWnd; AClassName,ACaption:PChar;
  ID:Integer=0; Style:Cardinal=0):PControl;
begin
  New(Result);
  Result.FHandle:=CreateWindowEx(Style, AClassName,ACaption, WS_CHILD or WS_VISIBLE,
    200,150,60,25, AParent.FHandle, ID, hInstance, nil);
  Result.Create(AParent);
end;

function CreateCtrlByType(AParent:PWnd; ControlType:TBasicControl;ACaption:PChar;
  ID:Integer=0; Style:Cardinal=0):PControl;
const Types:array[TBasicControl]of PChar=('Button','ComboBox','Edit',
  'ListBox','MDIClient','msctls_hotkey32','msctls_progress32',
  'msctls_statusbar32','msctls_trackbar32','msctls_updown32',
  'ReBarWindow32','RICHEDIT','ScrollBar','Static','SysAnimate32',
  'SysDateTimePick32','SysHeader32','SysListView32','SysMonthCal32',
  'SysPager','SysTabControl32','SysTreeView32','ToolbarWindow32');
begin
  Result:=CreateCtrl(AParent,Types[ControlType],ACaption,ID,Style);
end;

end.