unit _Forms;
{
  ver 1.4

  Mefistofel
    (Костромин Кирилл)
  03.01.2012

  all need system properties,
  application, windows, timers,
  keys and mouse creation and control procedures
}

interface

uses
  Windows,
  Messages,
  Types;

const
  // border_style
  bs_Caption = (WS_OVERLAPPED or WS_CAPTION or WS_SYSMENU or
    WS_MINIMIZEBOX or WS_MAXIMIZEBOX);//WS_OVERLAPPEDWINDOW;
  bs_None = (WS_MAXIMIZE or WS_POPUP or WS_SYSMENU or WS_MINIMIZEBOX) AND not WS_DLGFRAME;

{$REGION 'Keys'}
  KEY_SPACE = 32;  
  KEY_ENTER = 13;
  KEY_ALT   = 18;
  KEY_CTRL  = 17;
  KEY_ESC   = 27;  
  KEY_TILDA = 192;
  KEY_Q = 81;
  KEY_E = 69;
  KEY_D = 68;
  KEY_A = 65;
  KEY_S = 83;
  KEY_W = 87;  
  KEY_PLUS = 187;//and equal
  KEY_MINUS = 189;  
  KEY_ADD_PLUS = 107;
  KEY_ADD_MINUS = 109;
  KEY_RIGHT = 39;
  KEY_LEFT  = 37;
  KEY_DOWN  = 40;
  KEY_UP    = 38;
  KEY_F1 = 112;
  KEY_F2 = 113;
  KEY_F3 = 114;
  KEY_F4 = 115;
  KEY_F5 = 116;
  KEY_F6 = 117;
  KEY_F7 = 118;
  KEY_F8 = 119;
  KEY_F9 = 120;
  KEY_F10= 121;
{$ENDREGION}  

type
  TProcedure = procedure;
  TMethod = procedure of object;
  TTimerProcedure = procedure (dt: Double);

TSomeCallbackClass = class
  FCallBackMethod: TMethod;
  FCallBackProcedure: TProcedure;
  FIsMethod: Boolean;
  constructor Create(BackMethod: TMethod); overload;
  constructor Create(BackProcedure: TProcedure); overload;
  procedure UseCallBack;
end;

TMouseController = record
    x, y : Integer;                         //mouse coords
    Wheel: Integer;                         //mouse wheel
    mbl, mbr, mbm: Boolean;                 //mouse left/rigth/middle button
  end;

TWindow = class
  private             
    FHandle              : THandle;         
    FClass               : TWndClassEx;     
    FTitle               : PAnsiChar;       
    FFocus               : Boolean;         
    FWidth               : Integer;         
    FHeight              : Integer;         //window size (with borders)
    FLeft                : Integer;         
    FTop                 : Integer;         //window size (without borders)
    FCreateMarker        : Boolean;         
    FCloseMarker         : Boolean;         
    FPCreateProcedure    : TProcedure;      //outer creation procedure
    FPKillProcedure      : TProcedure;      //kil procedure
    FPStateProcedure     : TProcedure;      //shange state (resize/min/maximize/focus) procedure
    procedure SetTitle(Value: String);
    procedure FindWindowScale;
    procedure CreateWindowClass(Border: Cardinal);
    procedure ShowCurrentWindow;
    procedure CreateWindow(
      Title:PAnsiChar;                      //window name
      CreateProc, KillProc, StateProc: TProcedure; //main processing procedures
      Top, Left, Width ,Height: Integer; Border: Cardinal = bs_Caption);
    function  GetTitle:string;
    function  ProcessWindowMessage(wMessage: Cardinal; wParam, lParam: Cardinal): boolean;
  public
    Top,
    Left,                                   //window top/left
    Width,
    Height: Integer;                        //canvas size (without borders)
    Key: array [0..255] of Boolean;         //keyboard keys
    Mouse: TMouseController;
    procedure Set_Mouse(coord:array of Integer); overload;
    procedure Set_Mouse(x, y: Integer); overload;
    property Focus: Boolean read FFocus;
    property Handle: THandle read FHandle;
    property Title: String read GetTitle write SetTitle;
    procedure SetWindowRect;
    procedure Initialize;
    procedure Close;
    constructor Create(
      Title: PAnsiChar; //window name
      CreateProc, KillProc, StateProc: TProcedure;
      Top, Left, Width, Height: Integer; Border: Boolean = True); overload; //window size
    constructor Create(
      Title: PAnsiChar;
      CreateProc, KillProc, StateProc: TProcedure;
      Width, Height: integer; Border: Boolean = true); overload;
    constructor Create(
      Title: PAnsiChar; 
      CreateProc, KillProc, StateProc: TProcedure;
      Border: Boolean = True); overload;
  end;

var
  Window: TWindow;

implementation
//
constructor TSomeCallbackClass.Create(BackMethod: TMethod);
begin
  FIsMethod:= true;
  FCallBackMethod:= BackMethod;
end;

constructor TSomeCallbackClass.Create(BackProcedure: TProcedure); 
begin             
  FIsMethod:= false;
  FCallBackProcedure:= BackProcedure;
end;

procedure TSomeCallbackClass.UseCallBack;
begin
  if FIsMethod then
    FCallBackMethod
  else
    FCallBackProcedure;
end;

//Messages
{$REGION 'Windows_Messages'}
function MainProcedure (
  WH: THandle;
  nMsg: Cardinal;
  wParam, lParam: Cardinal): Cardinal; stdcall;
Var
 CurrentWindow: TWindow;
begin                 //Messages
  Result:= 0;
  CurrentWindow:= TWindow(GetWindowLongA(WH, GWL_USERDATA));
  if CurrentWindow <> nil then
    if CurrentWindow.ProcessWindowMessage(nMsg, wParam, lParam) then
      Exit;
  Result:= DefWindowProc (WH, nMsg, wParam, lParam);
end;
{$ENDREGION}

//TWindow
{$REGION 'Find Window Paint Canvas'}
procedure TWindow.FindWindowScale;
var
 Canvas_Size:TPoint;
 Rect:TRect;
begin
 GetDCOrgEx(GetDC(Handle), Canvas_Size);
 GetClientRect(Handle, Rect);
 FLeft:= Canvas_Size.X;
 FTop := Canvas_Size.Y;
 Width := Rect.Right;
 Height:= Rect.Bottom;
end;
{$ENDREGION}

{$REGION 'Create_Window_class'}
procedure TWindow.CreateWindowClass(Border:Cardinal);
begin
 FClass.cbSize:= sizeOf (FClass);
 FClass.lpszClassName:= FTitle;
 FClass.style:= cs_VRedraw or cs_HRedraw;
 FClass.hInstance:= HInstance;
 FClass.lpfnWndProc:= @MainProcedure;
 FClass.cbClsExtra:= 0;
 FClass.cbWndExtra:= 0;
 FClass.hInstance:= HInstance;
 FClass.hIcon  := LoadIcon (hInstance,  IDI_APPLICATION );   //default icons
 FClass.hIconSm:= LoadIcon (hInstance,  IDI_APPLICATION );
 FClass.hCursor:= LoadCursor (0, IDC_Arrow);
 FClass.hbrBackground:= COLOR_BTNFACE;
 FClass.lpszMenuName:= nil;
 RegisterClassEx (FClass);                  //register the class
 FHandle := CreateWindowEx (
  WS_EX_DLGMODALFRAME,                      //overlap window
  FClass.lpszClassName,                     //class name
  FTitle,                                   //caption
  Border,                                   //win style
  Top, Left,                                // position
  Width, Height,                            // size
  0,0,                                      // parent window, menu
  HInstance,                                // instance handle
  nil);                                     // initial parameters
end;
{$ENDREGION}

{$REGION 'Create'}
procedure TWindow.CreateWindow;
begin
  Self.Top := Top;
  Self.Left:= Left;
  Self.Width := Width;
  Self.Height:= Height;
  Self.FTitle:= Title;
  Self.FPCreateProcedure:= @CreateProc;
  Self.FPKillProcedure:=   @KillProc;
  Self.FPStateProcedure:=  @StateProc;
  CreateWindowClass(Border);
  FindWindowScale;              //recalculate Self scale 
  SetWindowLongA(Handle, GWL_USERDATA, Cardinal(Self));
end;

constructor TWindow.Create(Title: PAnsiChar;
    CreateProc, KillProc, StateProc: TProcedure;
    Top, Left, Width, Height: Integer; Border: Boolean = true);
var BorderState:Cardinal;
begin
  if Border then
    BorderState:= bs_Caption
  else
    BorderState:= bs_None;
  CreateWindow(Title, CreateProc, KillProc, StateProc,
     Top, Left, Width, Height, BorderState);
end;

constructor TWindow.Create(Title: PAnsiChar;
    CreateProc, KillProc, StateProc: TProcedure;
    Width, Height: Integer; Border: Boolean = true);
var BorderState:Cardinal;
begin
  if Border then
    BorderState:= bs_Caption
  else
    BorderState:= bs_None;
  CreateWindow(Title, CreateProc, KillProc, StateProc,
    0, 0, Width, Height, BorderState);
end;

constructor TWindow.Create(Title: PAnsiChar;
    CreateProc, KillProc, StateProc: TProcedure;
    Border: Boolean = true);
var BorderState: Cardinal;
begin
  if Border then
    BorderState:= bs_Caption
  else
    BorderState:= bs_None;
  CreateWindow(Title, CreateProc, KillProc, StateProc,
    0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN), BorderState);
end;
{$ENDREGION}

{$REGION 'Process messages'}
function TWindow.ProcessWindowMessage(wMessage: Cardinal; wParam, lParam: Cardinal): Boolean;
Var
 Cur:TPoint;
begin
  Result:= false;
  case wMessage of
    wm_lButtonDown:Mouse.mbl:= true;
    wm_lButtonUp:  Mouse.mbl:= false;
    wm_rButtonDown:Mouse.mbr:= true;
    wm_rButtonUp:  Mouse.mbr:= false;
    WM_MButtonDown:Mouse.mbm:= true;
    WM_MButtonUp:  Mouse.mbm:= false;
    WM_MouseMove:                         //mouse position
      begin
        GetCursorPos(Cur);
        Mouse.x:= Cur.X - FLeft;
        Mouse.y:= Cur.Y - FTop;
      end;
    wm_KeyDown:Self.key[wParam]:= true;
    wm_KeyUp:  Self.key[wParam]:= false;  //keys on/off
    wm_MouseWheel:Self.Mouse.Wheel:= wParam;  //mouse wheel
    wm_Activate:
      begin
        FFocus:=not (wparam = 0);         //active
        if FCreateMarker then
          FPStateProcedure;               //recalculate Self scale
      end;
    wm_Moving:
      begin
        FindWindowScale;
        if FCreateMarker then
          FPStateProcedure;               //recalculate Self scale
      end;
    wm_Size:
      begin
        Self.FWidth:=  LOWORD(lParam);
        Self.FHeight:= HIWORD(lParam);    //New Self size
        FindWindowScale;                  //Recalculate Self scale
        if FCreateMarker then
          FPStateProcedure;
      end;
    wm_Destroy:                           //Destroying
      begin
        if FCreateMarker then
          FPKillProcedure;
        Close;
        FCreateMarker:=false;
        Exit;
      end;
  end;
end;
{$ENDREGION}

{$REGION 'Title'}
function TWindow.GetTitle: string;
begin
 Result:= FTitle;
end;

procedure TWindow.SetTitle(Value: string);
begin
 FTitle:= PAnsiChar(Value);
 SendMessage(Self.Handle, WM_SETTEXT, 0, Integer(PChar(FTitle)));
end;
{$ENDREGION}

{$REGION 'Set Mouse Coord'}
procedure TWindow.Set_Mouse(Coord: array of Integer);
begin
 SetCursorPos(Coord[0], Coord[1]);
end;

procedure TWindow.Set_Mouse(x,y: Integer);
begin
 SetCursorPos(X + FLeft, Y + FTop);
end;
{$ENDREGION}

{$REGION 'Set mouse cliprect'}
procedure TWindow.SetWindowRect;
var
  MouseClipRect: TRect;
begin
  MouseClipRect:= Rect(FLeft, FTop, FLeft + FWidth, FTop + FHeight);
  ClipCursor(@MouseClipRect);
end;

{$ENDREGION}

{$REGION 'Show Window'}
procedure FillColor(Handle: hWnd; w, h: Integer; Color: Cardinal);
Var
  PaintDC : hDC;
  Info    : TPaintStruct;
  OldBrush: hBrush;
begin
  PaintDC:= BeginPaint(Handle, Info);
  OldBrush:= SelectObject(PaintDC, CreateSolidBrush(Color));
  Rectangle(PaintDC, 0, 0, w, h);
  DeleteObject(SelectObject(PaintDC, OldBrush));
  EndPaint(Handle, Info);
end;

procedure TWindow.ShowCurrentWindow();
begin
//  ShowWindow(FHandle, SW_SHOWMAXIMIZED);       //show
  ShowWindow(FHandle, SW_SHOWNORMAL);       //show
  FillColor(FHandle, Width, Height, $000000);
  FindWindowScale;
  FPCreateProcedure;               //set creation procedure
  FCloseMarker:= false;
  FCreateMarker:= true;            
  FFocus:= true;
end;
{$ENDREGION}

{$REGION 'Initialize'}
procedure TWindow.Initialize;
Var Msg: TMsg;
begin
  ShowCurrentWindow;
  while GetMessage (Msg, Handle, 0, 0) and not FCloseMarker do
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;             
  if Handle>0 then
    begin
      UnregisterClass(FTitle, FClass.hInstance);
      DestroyWindow(Handle);
    end;
  //Free;
end;
{$ENDREGION}

{$REGION 'Kill'}
procedure TWindow.Close;
begin
 FCloseMarker:= true;
end;
{$ENDREGION}

end.
