1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-24 16:28:53 -05:00
Simba/Units/MMLCore/os_windows.pas
2010-03-12 18:10:10 +01:00

431 lines
11 KiB
ObjectPascal

{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer
MML is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
MML is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with MML. If not, see <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Windows OS specific implementation for Mufasa Macro Library
}
{$mode objfpc}{$H+}
unit os_windows;
interface
uses
Classes, SysUtils, mufasatypes, windows, graphics, LCLType, bitmaps, LCLIntf, IOManager, WinKeyInput;
type
TNativeWindow = Hwnd;
TKeyInput = class(TWinKeyInput)
public
procedure Down(Key: Word);
procedure Up(Key: Word);
end;
{ TWindow }
TWindow = class(TWindow_Abstract)
public
constructor Create;
constructor Create(target: Hwnd);
destructor Destroy; override;
procedure GetTargetDimensions(var w, h: integer); override;
function ReturnData(xs, ys, width, height: Integer): TRetData; override;
function GetColor(x,y : integer) : TColor; override;
function GetError: String; override;
function ReceivedError: Boolean; override;
procedure ResetError; override;
function TargetValid: boolean; override;
procedure ActivateClient; override;
procedure GetMousePosition(var x,y: integer); override;
procedure MoveMouse(x,y: integer); override;
procedure HoldMouse(x,y: integer; button: TClickType); override;
procedure ReleaseMouse(x,y: integer; button: TClickType); override;
function IsMouseButtonHeld( button : TClickType) : boolean;override;
procedure SendString(str: string); override;
procedure HoldKey(key: integer); override;
procedure ReleaseKey(key: integer); override;
function IsKeyHeld(key: integer): boolean; override;
function GetKeyCode(c : char) : integer;override;
function GetNativeWindow: TNativeWindow;
private
handle: Hwnd;
dc: HDC;
buffer: TBitmap;
buffer_raw: prgb32;
width,height: integer;
keyinput: TKeyInput;
procedure ValidateBuffer(w,h:integer);
protected
function WindowRect : TRect;virtual;
end;
{ TDesktopWindow }
TDesktopWindow = class(TWindow)
private
constructor Create(DesktopHandle : HWND);
function WindowRect : TRect;override;
end;
TIOManager = class(TIOManager_Abstract)
public
constructor Create;
constructor Create(plugin_dir: string);
function SetTarget(target: TNativeWindow): integer; overload;
procedure SetDesktop; override;
protected
DesktopHWND : Hwnd;
procedure NativeInit; override;
procedure NativeFree; override;
end;
implementation
uses GraphType, interfacebase;
type
PMouseInput = ^TMouseInput;
tagMOUSEINPUT = packed record
dx: Longint;
dy: Longint;
mouseData: DWORD;
dwFlags: DWORD;
time: DWORD;
dwExtraInfo: DWORD;
end;
TMouseInput = tagMOUSEINPUT;
PKeybdInput = ^TKeybdInput;
tagKEYBDINPUT = packed record
wVk: WORD;
wScan: WORD;
dwFlags: DWORD;
time: DWORD;
dwExtraInfo: DWORD;
end;
TKeybdInput = tagKEYBDINPUT;
PHardwareInput = ^THardwareInput;
tagHARDWAREINPUT = packed record
uMsg: DWORD;
wParamL: WORD;
wParamH: WORD;
end;
THardwareInput = tagHARDWAREINPUT;
PInput = ^TInput;
tagINPUT = packed record
Itype: DWORD;
case Integer of
0: (mi: TMouseInput);
1: (ki: TKeybdInput);
2: (hi: THardwareInput);
end;
TInput = tagINPUT;
const
INPUT_MOUSE = 0;
INPUT_KEYBOARD = 1;
INPUT_HARDWARE = 2;
function SendInput(cInputs: UINT; var pInputs: TInput; cbSize: Integer): UINT; stdcall; external user32 name 'SendInput';
//***implementation*** TKeyInput
procedure TKeyInput.Down(Key: Word);
begin
DoDown(Key);
end;
procedure TKeyInput.Up(Key: Word);
begin
DoUp(Key);
end;
//***implementation*** TWindow
constructor TWindow.Create;
begin
inherited Create;
self.buffer:= TBitmap.Create;
self.buffer.PixelFormat:= pf32bit;
keyinput:= TKeyInput.Create;
end;
constructor TWindow.Create(target: Hwnd);
begin
self.create; //Call the other create
self.handle:= target;
self.dc:= GetWindowDC(target);
end;
destructor TWindow.Destroy;
begin
ReleaseDC(handle,dc);//Dogdy as one might have used .create and not set a handle..
buffer.Free;
keyinput.Free;
inherited Destroy;
end;
function TWindow.GetError: String;
begin
exit('');
end;
function TWindow.ReceivedError: Boolean;
begin
exit(false);
end;
procedure TWindow.ResetError;
begin
end;
function TWindow.GetNativeWindow: TNativeWindow;
begin
result := handle;
end;
function TWindow.TargetValid: boolean;
begin
result:= IsWindow(handle);
end;
procedure TWindow.ActivateClient;
begin
SetForegroundWindow(handle);
end;
procedure TWindow.GetTargetDimensions(var w, h: integer);
var
Rect : TRect;
begin
Rect := WindowRect;
w:= Rect.Right - Rect.Left;
h:= Rect.Bottom - Rect.Top;
end;
function TWindow.GetColor(x,y : integer) : TColor;
begin
result:= GetPixel(self.dc,x,y)
end;
procedure TWindow.ValidateBuffer(w,h:integer);
var
BmpInfo : Windows.TBitmap;
begin
if (w <> self.width) or (height <> self.height) then
begin
buffer.SetSize(w,h);
self.width:= w;
self.height:= h;
GetObject(buffer.Handle, SizeOf(BmpInfo), @BmpInfo);
self.buffer_raw := BmpInfo.bmBits;
end;
end;
function TWindow.WindowRect: TRect;
begin
GetWindowRect(self.handle,result);
end;
function TWindow.ReturnData(xs, ys, width, height: Integer): TRetData;
var
temp: PRGB32;
w,h : integer;
begin
GetTargetDimensions(w,h);
ValidateBuffer(w,h);
if (xs < 0) or (xs + width > w) or (ys < 0) or (ys + height > h) then
raise Exception.CreateFMT('TMWindow.ReturnData: The parameters passed are wrong; xs,ys %d,%d width,height %d,%d',[xs,ys,width,height]);
BitBlt(self.buffer.Canvas.Handle,0,0, width, height, self.dc, xs,ys, SRCCOPY);
Result.Ptr:= self.buffer_raw;
Result.IncPtrWith:= w - width;
Result.RowLen:= w;
end;
procedure TWindow.GetMousePosition(var x,y: integer);
var
MousePoint : TPoint;
Rect : TRect;
begin
Windows.GetCursorPos(MousePoint);
Rect := WindowRect;
x := MousePoint.x - Rect.Left;
y := MousePoint.y - Rect.Top;
end;
procedure TWindow.MoveMouse(x,y: integer);
var
rect : TRect;
w,h: integer;
begin
Rect := WindowRect;
x := x + rect.left;
y := y + rect.top;
{ if (x<0) or (y<0) then
writeln('Negative coords, what now?');}
Windows.SetCursorPos(x, y);
end;
procedure TWindow.HoldMouse(x,y: integer; button: TClickType);
var
Input : TInput;
Rect : TRect;
begin
Rect := WindowRect;
Input.Itype:= INPUT_MOUSE;
FillChar(Input,Sizeof(Input),0);
Input.mi.dx:= x + Rect.left;
Input.mi.dy:= y + Rect.Top;
case button of
Mouse_Left: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN;
Mouse_Middle: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MIDDLEDOWN;
Mouse_Right: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_RIGHTDOWN;
end;
SendInput(1,Input, sizeof(Input));
end;
procedure TWindow.ReleaseMouse(x,y: integer; button: TClickType);
var
Input : TInput;
Rect : TRect;
begin
Rect := WindowRect;
Input.Itype:= INPUT_MOUSE;
FillChar(Input,Sizeof(Input),0);
Input.mi.dx:= x + Rect.left;
Input.mi.dy:= y + Rect.Top;
case button of
Mouse_Left: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP;
Mouse_Middle: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MIDDLEUP;
Mouse_Right: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_RIGHTUP;
end;
SendInput(1,Input, sizeof(Input));
end;
function TWindow.IsMouseButtonHeld(button: TClickType): boolean;
begin
case button of
mouse_Left : Result := (GetAsyncKeyState(VK_LBUTTON) <> 0);
mouse_Middle : Result := (GetAsyncKeyState(VK_MBUTTON) <> 0);
mouse_Right : Result := (GetAsyncKeyState(VK_RBUTTON) <> 0);
end;
end;
procedure TWindow.SendString(str: string);
var
i: integer;
key: byte;
HoldShift : boolean;
begin
HoldShift := false;
for i := 1 to length(str) do
begin
if((str[i] >= 'A') and (str[i] <= 'Z')) then
begin
HoldKey(VK_SHIFT);
HoldShift:= True;
str[i] := lowerCase(str[i]);
end else
if HoldShift then
begin
HoldShift:= false;
ReleaseKey(VK_SHIFT);
end;
key:= GetKeyCode(str[i]);
HoldKey(key);
//BenLand100 note: probably should wait here
ReleaseKey(key);
end;
if HoldShift then
ReleaseKey(VK_SHIFT);
end;
procedure TWindow.HoldKey(key: integer);
begin
keyinput.Down(key);
end;
procedure TWindow.ReleaseKey(key: integer);
begin
keyinput.Up(key);
end;
function TWindow.IsKeyHeld(key: integer): boolean;
begin
Result := (GetAsyncKeyState(key) <> 0);
end;
function TWindow.GetKeyCode(c: char): integer;
begin
result := VkKeyScan(c) and $FF;
end;
//***implementation*** IOManager
constructor TIOManager.Create;
begin
inherited Create;
end;
constructor TIOManager.Create(plugin_dir: string);
begin
inherited Create(plugin_dir);
end;
procedure TIOManager.NativeInit;
begin
self.DesktopHWND:= GetDesktopWindow;
end;
procedure TIOManager.NativeFree;
begin
end;
procedure TIOManager.SetDesktop;
begin
SetBothTargets(TDesktopWindow.Create(DesktopHWND));
end;
function TIOManager.SetTarget(target: TNativeWindow): integer;
begin
SetBothTargets(TWindow.Create(target));
end;
{ TDesktopWindow }
constructor TDesktopWindow.Create(DesktopHandle: HWND);
begin
inherited Create;
self.dc := GetDC(DesktopHandle);
self.handle:= DesktopHandle;
end;
function TDesktopWindow.WindowRect: TRect;
begin
result.Left:= GetSystemMetrics(SM_XVIRTUALSCREEN);
result.Top:= GetSystemMetrics(SM_YVIRTUALSCREEN);
result.Right := GetSystemMetrics(SM_CXVIRTUALSCREEN);
result.Bottom:= GetSystemMetrics(SM_CYVIRTUALSCREEN);
end;
end.