1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-11 11:55:02 -05:00

Added ScrollMouse, BiDiMode and added CopyClientToBitmap to the TMufasaBitmap

This commit is contained in:
Raymond 2010-05-19 22:36:45 +02:00
parent 65f37d861e
commit 780190e2c7
12 changed files with 131 additions and 30 deletions

View File

@ -175,6 +175,11 @@ begin
end; end;
procedure TMufasaBitmapCopyClientToBitmap(self : TMufasaBitmap; Resize : boolean;x,y : integer; xs, ys, xe, ye: Integer);
begin
self.CopyClientToBitmap(SimbaForm.Manager,resize,x,y,xs,ys,xe,ye);
end;
procedure TSimbaPSExtension.RegisterPSCComponents(Sender: TObject; x: TPSPascalCompiler); procedure TSimbaPSExtension.RegisterPSCComponents(Sender: TObject; x: TPSPascalCompiler);
begin begin
SIRegister_Std(x); SIRegister_Std(x);
@ -199,6 +204,8 @@ begin
RIRegister_ExtCtrls(x); RIRegister_ExtCtrls(x);
RIRegister_Menus(x); RIRegister_Menus(x);
RIRegister_MML(x); RIRegister_MML(x);
with x.FindClass('TMufasaBitmap') do
RegisterMethod(@TMufasaBitmapCopyClientToBitmap,'CopyClientToBitmap');
end; end;
destructor TSimbaPSExtension.Destroy; destructor TSimbaPSExtension.Destroy;

View File

@ -27,7 +27,12 @@ const
ps_mouse_middle = 2; ps_mouse_middle = 2;
procedure ps_MoveMouse(x, y: integer); extdecl; procedure ps_MoveMouse(x, y: integer); extdecl;
begin begin
CurrThread.Client.IOManager.SetMousePos(X, Y); CurrThread.Client.IOManager.MoveMouse(X, Y);
end;
procedure ps_ScrollMouse(x,y : integer; Clicks : integer); extdecl;
begin
CurrThread.Client.IOManager.ScrollMouse(x,y,Clicks);
end; end;
procedure ps_GetMousePos(var x, y: integer); extdecl; procedure ps_GetMousePos(var x, y: integer); extdecl;

View File

@ -44,7 +44,7 @@ x.AddTypeS('TPointArrayArray','Array of TPointArray');
x.AddTypeS('TBmpMirrorStyle','(MirrorWidth,MirrorHeight,MirrorLine)'); x.AddTypeS('TBmpMirrorStyle','(MirrorWidth,MirrorHeight,MirrorLine)');
x.AddTypeS('TMask','record White, Black : TPointArray; WhiteHi,BlackHi : integer; W,H : integer;end;'); x.AddTypeS('TMask','record White, Black : TPointArray; WhiteHi,BlackHi : integer; W,H : integer;end;');
x.addtypeS('PPoint','record R,T : extended; end;'); x.addtypeS('PPoint','record R,T : extended; end;');
x.AddTypeS('TTarget_Exported','record int1,int2,int3,int4,int5,int6,int7,int8,int9,int10,int11,int12,int13,int14,int15:integer; end;'); x.AddTypeS('TTarget_Exported','record int1,int2,int3,int4,int5,int6,int7,int8,int9,int10,int11,int12,int13,int14,int15,int16:integer; end;');
x.AddTypes('TSDTMPointDef', 'record x, y, Color, Tolerance, AreaSize, AreaShape: integer; end;'); x.AddTypes('TSDTMPointDef', 'record x, y, Color, Tolerance, AreaSize, AreaShape: integer; end;');
x.AddTypes('TSDTMPointDefArray', 'Array Of TSDTMPointDef;'); x.AddTypes('TSDTMPointDefArray', 'Array Of TSDTMPointDef;');

View File

@ -238,6 +238,7 @@ AddFunction(@ps_FindColoredAreaTolerance, 'function FindColoredAreaTolerance(var
{Mouse etc.} {Mouse etc.}
SetCurrSection('Mouse'); SetCurrSection('Mouse');
AddFunction(@ps_MoveMouse, 'procedure MoveMouse(x, y: integer);'); AddFunction(@ps_MoveMouse, 'procedure MoveMouse(x, y: integer);');
AddFunction(@ps_ScrollMouse,'procedure Scrollmouse(x,y : integer; Clicks : integer);');
AddFunction(@ps_GetMousePos, 'procedure GetMousePos(var x, y: integer);'); AddFunction(@ps_GetMousePos, 'procedure GetMousePos(var x, y: integer);');
AddFunction(@ps_HoldMouse, 'procedure HoldMouse(x, y: integer; clickType: integer);'); AddFunction(@ps_HoldMouse, 'procedure HoldMouse(x, y: integer; clickType: integer);');
AddFunction(@ps_ReleaseMouse, 'procedure ReleaseMouse(x, y: integer; clickType: integer);'); AddFunction(@ps_ReleaseMouse, 'procedure ReleaseMouse(x, y: integer; clickType: integer);');

View File

@ -6,12 +6,10 @@ uses
procedure SIRegister_MML(cl: TPSPascalCompiler); procedure SIRegister_MML(cl: TPSPascalCompiler);
implementation implementation
procedure SIRegister_MML(cl: TPSPascalCompiler);
var procedure SIRegister_TMufasaBitmap(cl : TPSPascalCompiler);
PSClass : TPSCompileTimeClass;
begin begin
PSClass :=cl.AddClassN(cl.FindClass('TObject'),'TMufasaBitmap'); with cl.AddClassN(cl.FindClass('TObject'),'TMufasaBitmap') do
with PSClass do
begin; begin;
RegisterMethod('procedure SetSize(AWidth,AHeight : integer);'); RegisterMethod('procedure SetSize(AWidth,AHeight : integer);');
RegisterMethod('procedure StretchResize(AWidth,AHeight : integer);'); RegisterMethod('procedure StretchResize(AWidth,AHeight : integer);');
@ -20,6 +18,7 @@ begin
RegisterMethod('procedure DrawATPA(ATPA : T2DPointArray; Colors : TIntegerArray);'); RegisterMethod('procedure DrawATPA(ATPA : T2DPointArray; Colors : TIntegerArray);');
RegisterMethod('procedure DrawTPA(TPA : TPointArray; Color : TColor);'); RegisterMethod('procedure DrawTPA(TPA : TPointArray; Color : TColor);');
RegisterMethod('function FastGetPixel(x,y : integer) : TColor;'); RegisterMethod('function FastGetPixel(x,y : integer) : TColor;');
RegisterMethod('procedure CopyClientToBitmap(Resize : boolean;x,y : integer; xs, ys, xe, ye: Integer);');
RegisterMethod('procedure Rectangle(const Box : TBox; FillCol : TColor);'); RegisterMethod('procedure Rectangle(const Box : TBox; FillCol : TColor);');
RegisterMethod('procedure FloodFill(const StartPT : TPoint; const SearchCol,ReplaceCol : TColor);'); RegisterMethod('procedure FloodFill(const StartPT : TPoint; const SearchCol,ReplaceCol : TColor);');
// function FastGetPixels(TPA : TPointArray) : TIntegerArray; // function FastGetPixels(TPA : TPointArray) : TIntegerArray;
@ -49,13 +48,16 @@ begin
RegisterProperty('Index','Integer',iptR); RegisterProperty('Index','Integer',iptR);
RegisterProperty('Name','String',iptRW); RegisterProperty('Name','String',iptRW);
end; end;
end;
procedure SIRegister_TRegExp(cl : TPSPascalCompiler);
begin
with CL.AddClassN(CL.FindClass('Exception'),'ERegExpr') do with CL.AddClassN(CL.FindClass('Exception'),'ERegExpr') do
begin begin
RegisterProperty('ErrorCode', 'integer', iptrw); RegisterProperty('ErrorCode', 'integer', iptrw);
RegisterProperty('CompilerErrorPos', 'integer', iptrw); RegisterProperty('CompilerErrorPos', 'integer', iptrw);
end; end;
PSClass :=cl.AddClassN(cl.FindClass('TObject'),'TRegExp'); with cl.AddClassN(cl.FindClass('TObject'),'TRegExp') do
with PSClass do
begin begin
RegisterMethod('Constructor Create'); RegisterMethod('Constructor Create');
RegisterMethod('Function VersionMajor : integer'); RegisterMethod('Function VersionMajor : integer');
@ -91,8 +93,11 @@ begin
RegisterMethod('Procedure Compile'); RegisterMethod('Procedure Compile');
RegisterMethod('Function Dump : String'); RegisterMethod('Function Dump : String');
end; end;
PSClass :=cl.AddClassN(cl.FindClass('TObject'),'TMDTM'); end;
with PSClass do
procedure SIRegister_TMDTM(cl : TPSPascalCompiler);
begin
with cl.AddClassN(cl.FindClass('TObject'),'TMDTM') do
begin begin
RegisterMethod('constructor create;'); RegisterMethod('constructor create;');
RegisterMethod('procedure free;'); RegisterMethod('procedure free;');
@ -106,6 +111,10 @@ begin
RegisterProperty('Count','Integer',iptrw); RegisterProperty('Count','Integer',iptrw);
RegisterProperty('Points','TMDTMPointArray',iptr); RegisterProperty('Points','TMDTMPointArray',iptr);
end; end;
end;
procedure SIRegister_TMMLSettingsSandbox(CL : TPSPascalCompiler);
begin
with cl.AddClassN(nil,'TMMLSettingsSandbox') do with cl.AddClassN(nil,'TMMLSettingsSandbox') do
begin; begin;
RegisterMethod('function IsKey(const KeyName: String): Boolean;'); RegisterMethod('function IsKey(const KeyName: String): Boolean;');
@ -120,4 +129,12 @@ begin
end; end;
end; end;
procedure SIRegister_MML(cl: TPSPascalCompiler);
begin
SIRegister_TMufasaBitmap(cl);
SIRegister_TRegExp(cl);
SIRegister_TMDTM(cL);
SIRegister_TMMLSettingsSandbox(cl);
end;
end. end.

View File

@ -63,12 +63,10 @@ procedure TMDTMCount_R(Self: TMDTM; var T: Integer);begin T := Self.Count; end;
procedure TMDTMPoints_R(Self : TMDTM; var T : TMDTMPointArray); begin t := self.Points; end; procedure TMDTMPoints_R(Self : TMDTM; var T : TMDTMPointArray); begin t := self.Points; end;
procedure SettingsPrefix(self : TMMLSettingsSandbox; var Prefix : String);begin; Prefix := self.Prefix; end; procedure SettingsPrefix(self : TMMLSettingsSandbox; var Prefix : String);begin; Prefix := self.Prefix; end;
procedure RIRegister_MML(cl: TPSRuntimeClassImporter);
var procedure RIRegister_TMufasaBitmap(cl : TPSRuntimeClassImporter);
PSClass : TPSRuntimeClass; begin
begin; with cl.Add(TMufasaBitmap) do
PSClass :=cl.Add(TMufasaBitmap);
with PSClass do
begin begin
RegisterMethod(@TMufasaBitmap.ToTBitmap,'ToTBitmap'); RegisterMethod(@TMufasaBitmap.ToTBitmap,'ToTBitmap');
RegisterMethod(@TMufasaBitmap.SetSize,'SETSIZE'); RegisterMethod(@TMufasaBitmap.SetSize,'SETSIZE');
@ -105,6 +103,10 @@ begin;
RegisterMethod(@TMufasaBitmap.SaveToFile, 'SAVETOFILE'); RegisterMethod(@TMufasaBitmap.SaveToFile, 'SAVETOFILE');
RegisterMethod(@TMufasaBitmap.LoadFromFile, 'LOADFROMFILE'); RegisterMethod(@TMufasaBitmap.LoadFromFile, 'LOADFROMFILE');
end; end;
end;
procedure RIRegister_TRegExp(cl : TPSRuntimeClassImporter);
begin
with CL.Add(ERegExpr) do with CL.Add(ERegExpr) do
begin begin
RegisterPropertyHelper(@ERegExprErrorCode_R,@ERegExprErrorCode_W,'ErrorCode'); RegisterPropertyHelper(@ERegExprErrorCode_R,@ERegExprErrorCode_W,'ErrorCode');
@ -146,6 +148,9 @@ begin;
RegisterMethod(@TRegExp.Compile, 'Compile'); RegisterMethod(@TRegExp.Compile, 'Compile');
RegisterMethod(@TRegExp.Dump, 'Dump'); RegisterMethod(@TRegExp.Dump, 'Dump');
end; end;
end;
procedure RIRegister_TMDTM(cl : TPSRuntimeClassImporter);
begin
with CL.Add(TMDTM) do with CL.Add(TMDTM) do
begin begin
RegisterConstructor(@TMDTM.Create,'Create'); RegisterConstructor(@TMDTM.Create,'Create');
@ -159,6 +164,9 @@ begin;
RegisterPropertyHelper(@TMDTMCount_R,@TMDTMCount_W,'Count'); RegisterPropertyHelper(@TMDTMCount_R,@TMDTMCount_W,'Count');
RegisterPropertyHelper(@TMDTMPoints_R,nil,'Points'); RegisterPropertyHelper(@TMDTMPoints_R,nil,'Points');
end; end;
end;
procedure RIRegister_TMMLSettingsSandbox(cl : TPSRuntimeClassImporter);
begin
with cl.Add(TMMLSettingsSandbox) do with cl.Add(TMMLSettingsSandbox) do
begin begin
RegisterMethod(@TMMLSettingsSandbox.IsKey,'ISKEY'); RegisterMethod(@TMMLSettingsSandbox.IsKey,'ISKEY');
@ -173,4 +181,12 @@ begin;
end; end;
end; end;
procedure RIRegister_MML(cl: TPSRuntimeClassImporter);
begin;
RIRegister_TMufasaBitmap(cl);
RIRegister_TRegExp(cl);
RIRegister_TMDTM(cl);
RIRegister_TMMLSettingsSandbox(cl);
end;
end. end.

View File

@ -204,14 +204,14 @@ uses
colour_conv,dtmutil, colour_conv,dtmutil,
{$ifdef mswindows}windows, MMSystem,{$endif}//MMSystem -> Sounds {$ifdef mswindows}windows, MMSystem,{$endif}//MMSystem -> Sounds
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, uPSC_menus, uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, uPSC_menus,
uPSC_extctrls, //Compile-libs uPSC_extctrls, uPSC_mml, //Compile-libs
uPSUtils, uPSUtils,
fontloader, fontloader,
IOmanager,//TTarget_Exported IOmanager,//TTarget_Exported
IniFiles,//Silly INI files IniFiles,//Silly INI files
stringutil, //String st00f stringutil, //String st00f
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms, uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms, uPSR_mml,
uPSR_menus, uPSI_ComCtrls, uPSI_Dialogs, uPSR_menus, uPSI_ComCtrls, uPSI_Dialogs,
files, files,
dialogs, dialogs,
@ -666,8 +666,6 @@ begin
'{$IFDEF __REMOVE_IS_INCLUDE}{$UNDEF IS_INCLUDE}{$ENDIF}'; '{$IFDEF __REMOVE_IS_INCLUDE}{$UNDEF IS_INCLUDE}{$ENDIF}';
end; end;
{$I PSInc/pscmml.inc}
procedure SIRegister_Mufasa(cl: TPSPascalCompiler); procedure SIRegister_Mufasa(cl: TPSPascalCompiler);
begin begin
SIRegister_MML(cl); SIRegister_MML(cl);
@ -714,7 +712,6 @@ begin
end; end;
end; end;
{$I PSInc/psrmml.inc}
function TMufasaBitmapCreate : TMufasaBitmap; function TMufasaBitmapCreate : TMufasaBitmap;
begin; begin;
result := TMufasaBitmap.Create; result := TMufasaBitmap.Create;
@ -726,6 +723,10 @@ begin
result := Self.Copy(xs,ys,xe,ye); result := Self.Copy(xs,ys,xe,ye);
CurrThread.Client.MBitmaps.AddBMP(result); CurrThread.Client.MBitmaps.AddBMP(result);
end; end;
procedure TMufasaBitmapCopyClientToBitmap(self : TMufasaBitmap; Resize : boolean;x,y : integer; xs, ys, xe, ye: Integer);
begin
self.CopyClientToBitmap(CurrThread.Client.IOManager,resize,x,y,xs,ys,xe,ye);
end;
function TMDTMCreate : TMDTM; function TMDTMCreate : TMDTM;
begin begin
result := TMDTM.Create; result := TMDTM.Create;
@ -745,6 +746,7 @@ begin
RegisterConstructor(@TMufasaBitmapCreate,'Create'); RegisterConstructor(@TMufasaBitmapCreate,'Create');
RegisterMethod(@TMufasaBitmapFree,'Free'); RegisterMethod(@TMufasaBitmapFree,'Free');
RegisterMethod(@TMufasaBitmapCopy,'Copy'); RegisterMethod(@TMufasaBitmapCopy,'Copy');
RegisterMethod(@TMufasaBitmapCopyClientToBitmap,'CopyClientToBitmap');
end; end;
With cl.FindClass('TMDTM') do With cl.FindClass('TMDTM') do
begin begin

View File

@ -966,12 +966,11 @@ var
begin begin
if Resize then if Resize then
Self.SetSize(xe-xs+1 + x,ye-ys+1 + y); Self.SetSize(xe-xs+1 + x,ye-ys+1 + y);
ValidatePoint(x,y);
wi := Min(xe-xs + 1 + x,Self.w); wi := Min(xe-xs + 1 + x,Self.w)-x;
hi := Min(ye-ys + 1 + y,Self.h); hi := Min(ye-ys + 1 + y,Self.h)-y;
PtrRet := TIOManager_Abstract(MWindow).ReturnData(xs,ys,wi - x,hi - y); PtrRet := TIOManager_Abstract(MWindow).ReturnData(xs,ys,wi,hi);
for yy := 0 to (hi-1) do
for yy := 0 to (hi-1 - y) do
Move(PtrRet.Ptr[yy * (PtrRet.RowLen)], FData[(yy + y) * self.w + x],wi * SizeOf(TRGB32)); Move(PtrRet.Ptr[yy * (PtrRet.RowLen)], FData[(yy + y) * self.w + x],wi * SizeOf(TRGB32));
TIOManager_Abstract(MWindow).FreeReturnData; TIOManager_Abstract(MWindow).FreeReturnData;
end; end;

View File

@ -58,6 +58,7 @@ interface
| raise exceptions } | raise exceptions }
procedure GetMousePosition(var x,y: integer); virtual; procedure GetMousePosition(var x,y: integer); virtual;
procedure MoveMouse(x,y: integer); virtual; procedure MoveMouse(x,y: integer); virtual;
procedure ScrollMouse(x,y : integer; Lines : integer); virtual;
procedure HoldMouse(x,y: integer; button: TClickType); virtual; procedure HoldMouse(x,y: integer; button: TClickType); virtual;
procedure ReleaseMouse(x,y: integer; button: TClickType); virtual; procedure ReleaseMouse(x,y: integer; button: TClickType); virtual;
function IsMouseButtonHeld( button : TClickType) : boolean ; virtual; function IsMouseButtonHeld( button : TClickType) : boolean ; virtual;
@ -114,6 +115,7 @@ interface
procedure ActivateClient; override; abstract; procedure ActivateClient; override; abstract;
procedure GetMousePosition(var x,y: integer); override; abstract; procedure GetMousePosition(var x,y: integer); override; abstract;
procedure MoveMouse(x,y: integer); override; abstract; procedure MoveMouse(x,y: integer); override; abstract;
procedure ScrollMouse(x,y : integer; Lines : integer); override; abstract;
procedure HoldMouse(x,y: integer; button: TClickType); override; abstract; procedure HoldMouse(x,y: integer; button: TClickType); override; abstract;
procedure ReleaseMouse(x,y: integer; button: TClickType); override; abstract; procedure ReleaseMouse(x,y: integer; button: TClickType); override; abstract;
function IsMouseButtonHeld( button : TClickType) : boolean;override; abstract; function IsMouseButtonHeld( button : TClickType) : boolean;override; abstract;
@ -140,6 +142,7 @@ interface
GetMousePosition: procedure(target: pointer; var x,y: integer); stdcall; GetMousePosition: procedure(target: pointer; var x,y: integer); stdcall;
MoveMouse: procedure(target: pointer; x,y: integer); stdcall; MoveMouse: procedure(target: pointer; x,y: integer); stdcall;
ScrollMouse: procedure(target : pointer; x,y : integer; lines : integer); stdcall;
HoldMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall; HoldMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall;
ReleaseMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall; ReleaseMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall;
IsMouseButtonHeld : function (target : pointer; left : Boolean) : boolean; stdcall; IsMouseButtonHeld : function (target : pointer; left : Boolean) : boolean; stdcall;
@ -170,6 +173,7 @@ interface
procedure GetMousePosition(var x,y: integer); override; procedure GetMousePosition(var x,y: integer); override;
procedure MoveMouse(x,y: integer); override; procedure MoveMouse(x,y: integer); override;
procedure ScrollMouse(x,y : integer; Lines : integer); override;
procedure HoldMouse(x,y: integer; button: TClickType); override; procedure HoldMouse(x,y: integer; button: TClickType); override;
procedure ReleaseMouse(x,y: integer; button: TClickType); override; procedure ReleaseMouse(x,y: integer; button: TClickType); override;
function IsMouseButtonHeld( button : TClickType) : boolean;override; function IsMouseButtonHeld( button : TClickType) : boolean;override;
@ -229,6 +233,7 @@ interface
GetMousePosition: procedure(target: pointer; var x,y: integer); stdcall; GetMousePosition: procedure(target: pointer; var x,y: integer); stdcall;
MoveMouse: procedure(target: pointer; x,y: integer); stdcall; MoveMouse: procedure(target: pointer; x,y: integer); stdcall;
ScrollMouse: procedure(target: pointer; x,y : integer; Lines : integer); stdcall;
HoldMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall; HoldMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall;
ReleaseMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall; ReleaseMouse: procedure(target: pointer; x,y: integer; left: boolean); stdcall;
IsMouseButtonHeld : function (target : pointer; left : boolean) : boolean;stdcall; IsMouseButtonHeld : function (target : pointer; left : boolean) : boolean;stdcall;
@ -279,7 +284,8 @@ interface
procedure SetFrozen(makefrozen: boolean); procedure SetFrozen(makefrozen: boolean);
procedure GetMousePos(var X, Y: Integer); procedure GetMousePos(var X, Y: Integer);
procedure SetMousePos(X, Y: Integer); procedure MoveMouse(X, Y: Integer);
procedure ScrollMouse(x,y : integer; Lines : integer);
procedure HoldMouse(x,y : integer; button: TClickType); procedure HoldMouse(x,y : integer; button: TClickType);
procedure ReleaseMouse(x,y : integer; button: TClickType); procedure ReleaseMouse(x,y : integer; button: TClickType);
procedure ClickMouse(X, Y: Integer; button: TClickType); procedure ClickMouse(X, Y: Integer; button: TClickType);
@ -334,6 +340,7 @@ interface
procedure TTarget_Exported_GetMousePosition(target: pointer; var x,y: integer); stdcall; procedure TTarget_Exported_GetMousePosition(target: pointer; var x,y: integer); stdcall;
procedure TTarget_Exported_MoveMouse(target: pointer; x,y: integer); stdcall; procedure TTarget_Exported_MoveMouse(target: pointer; x,y: integer); stdcall;
procedure TTarget_Exported_ScrollMouse(target: pointer; x,y : integer; Lines : integer); stdcall;
procedure TTarget_Exported_HoldMouse(target: pointer; x,y: integer; left: boolean); stdcall; procedure TTarget_Exported_HoldMouse(target: pointer; x,y: integer; left: boolean); stdcall;
procedure TTarget_Exported_ReleaseMouse(target: pointer; x,y: integer; left: boolean); stdcall; procedure TTarget_Exported_ReleaseMouse(target: pointer; x,y: integer; left: boolean); stdcall;
function TTarget_Exported_IsMouseButtonHeld(target: pointer; left : boolean) : boolean;stdcall; function TTarget_Exported_IsMouseButtonHeld(target: pointer; left : boolean) : boolean;stdcall;
@ -473,6 +480,7 @@ begin
Target:= KeyMouse; Target:= KeyMouse;
GetMousePosition := @TTarget_Exported_GetMousePosition; GetMousePosition := @TTarget_Exported_GetMousePosition;
MoveMouse := @TTarget_Exported_MoveMouse; MoveMouse := @TTarget_Exported_MoveMouse;
ScrollMouse:= @TTarget_Exported_ScrollMouse;
HoldMouse := @TTarget_Exported_HoldMouse; HoldMouse := @TTarget_Exported_HoldMouse;
ReleaseMouse := @TTarget_Exported_ReleaseMouse; ReleaseMouse := @TTarget_Exported_ReleaseMouse;
@ -602,10 +610,17 @@ procedure TIOManager_Abstract.GetMousePos(var X, Y: Integer);
begin begin
keymouse.GetMousePosition(x,y) keymouse.GetMousePosition(x,y)
end; end;
procedure TIOManager_Abstract.SetMousePos(X, Y: Integer);
procedure TIOManager_Abstract.MoveMouse(X, Y: Integer);
begin begin
keymouse.MoveMouse(x,y); keymouse.MoveMouse(x,y);
end; end;
procedure TIOManager_Abstract.ScrollMouse(x, y: integer; Lines: integer);
begin
keymouse.ScrollMouse(x,y,lines);
end;
procedure TIOManager_Abstract.HoldMouse(x,y : integer; button: TClickType); procedure TIOManager_Abstract.HoldMouse(x,y : integer; button: TClickType);
begin begin
keymouse.HoldMouse(x,y,button); keymouse.HoldMouse(x,y,button);
@ -698,6 +713,7 @@ function TTarget.TargetValid: boolean; begin result:= true; end;
procedure TTarget.GetMousePosition(var x,y: integer); begin raise Exception.Create('GetMousePosition not available for this target'); end; procedure TTarget.GetMousePosition(var x,y: integer); begin raise Exception.Create('GetMousePosition not available for this target'); end;
procedure TTarget.MoveMouse(x,y: integer); begin raise Exception.Create('MoveMouse not available for this target'); end; procedure TTarget.MoveMouse(x,y: integer); begin raise Exception.Create('MoveMouse not available for this target'); end;
procedure TTarget.ScrollMouse(x,y : integer; lines : integer); begin raise Exception.Create('ScrollMouse is not available for this target'); end;
procedure TTarget.HoldMouse(x,y: integer; button: TClickType); begin raise Exception.Create('HoldMouse not available for this target'); end; procedure TTarget.HoldMouse(x,y: integer; button: TClickType); begin raise Exception.Create('HoldMouse not available for this target'); end;
procedure TTarget.ReleaseMouse(x,y: integer; button: TClickType); begin raise Exception.Create('ReleaseMouse not available for this target'); end; procedure TTarget.ReleaseMouse(x,y: integer; button: TClickType); begin raise Exception.Create('ReleaseMouse not available for this target'); end;
function TTarget.IsMouseButtonHeld(button: TClickType): boolean; begin raise Exception.Create('IsMouseButtonHeld not available for this target'); end; function TTarget.IsMouseButtonHeld(button: TClickType): boolean; begin raise Exception.Create('IsMouseButtonHeld not available for this target'); end;
@ -763,6 +779,14 @@ begin
else else
inherited MoveMouse(x,y); inherited MoveMouse(x,y);
end; end;
procedure TEIOS_Target.ScrollMouse(x,y : integer; Lines : integer);
begin
if Pointer(Client.ScrollMouse) <> nil then
client.ScrollMouse(target,x,y,lines)
else
inherited Scrollmouse(x,y,lines);
end;
procedure TEIOS_Target.HoldMouse(x,y: integer; button: TClickType); procedure TEIOS_Target.HoldMouse(x,y: integer; button: TClickType);
begin begin
if Pointer(client.HoldMouse) <> nil then if Pointer(client.HoldMouse) <> nil then
@ -942,6 +966,7 @@ begin
Pointer(GetMousePosition):= GetProcAddress(plugin, PChar('EIOS_GetMousePosition')); Pointer(GetMousePosition):= GetProcAddress(plugin, PChar('EIOS_GetMousePosition'));
Pointer(MoveMouse):= GetProcAddress(plugin, PChar('EIOS_MoveMouse')); Pointer(MoveMouse):= GetProcAddress(plugin, PChar('EIOS_MoveMouse'));
Pointer(ScrollMouse) := GetProcAddress(plugin,PChar('EIOS_ScrollMouse'));
Pointer(HoldMouse):= GetProcAddress(plugin, PChar('EIOS_HoldMouse')); Pointer(HoldMouse):= GetProcAddress(plugin, PChar('EIOS_HoldMouse'));
Pointer(ReleaseMouse):= GetProcAddress(plugin, PChar('EIOS_ReleaseMouse')); Pointer(ReleaseMouse):= GetProcAddress(plugin, PChar('EIOS_ReleaseMouse'));
@ -1011,6 +1036,11 @@ procedure TTarget_Exported_MoveMouse(target: pointer; x, y: integer); stdcall;
begin begin
TTarget(Target).MoveMouse(x,y); TTarget(Target).MoveMouse(x,y);
end; end;
procedure TTarget_Exported_ScrollMouse(target: pointer; x, y: integer;
Lines: integer); stdcall;
begin
TTarget(Target).ScrollMouse(x,y,lines);
end;
procedure TTarget_Exported_HoldMouse(target: pointer; x, y: integer; procedure TTarget_Exported_HoldMouse(target: pointer; x, y: integer;
left: boolean); stdcall; left: boolean); stdcall;

View File

@ -58,6 +58,7 @@ interface
procedure ActivateClient; override; procedure ActivateClient; override;
procedure GetMousePosition(var x,y: integer); override; procedure GetMousePosition(var x,y: integer); override;
procedure MoveMouse(x,y: integer); override; procedure MoveMouse(x,y: integer); override;
procedure ScrollMouse(x,y, lines : integer); override;
procedure HoldMouse(x,y: integer; button: TClickType); override; procedure HoldMouse(x,y: integer; button: TClickType); override;
procedure ReleaseMouse(x,y: integer; button: TClickType); override; procedure ReleaseMouse(x,y: integer; button: TClickType); override;
function IsMouseButtonHeld( button : TClickType) : boolean;override; function IsMouseButtonHeld( button : TClickType) : boolean;override;
@ -290,6 +291,24 @@ implementation
y := y + rect.top; y := y + rect.top;
Windows.SetCursorPos(x, y); Windows.SetCursorPos(x, y);
end; end;
const
MOUSEEVENTF_WHEEL = $800;
procedure TWindow.ScrollMouse(x, y, lines: integer);
var
Input : TInput;
Rect : TRect;
begin
WindowRect(rect);
Input.Itype:= INPUT_MOUSE;
FillChar(Input,Sizeof(Input),0);
Input.mi.dx:= x + Rect.left;
Input.mi.dy:= y + Rect.Top;
Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_WHEEL;
Input.mi.mouseData:= lines * WHEEL_DELTA;
SendInput(1,Input, sizeof(Input));
end;
procedure TWindow.HoldMouse(x,y: integer; button: TClickType); procedure TWindow.HoldMouse(x,y: integer; button: TClickType);
var var
Input : TInput; Input : TInput;

View File

@ -53,6 +53,7 @@ begin
RegisterProperty('Visible', 'Boolean', iptRW); RegisterProperty('Visible', 'Boolean', iptRW);
RegisterProperty('ENABLED', 'BOOLEAN', iptrw); RegisterProperty('ENABLED', 'BOOLEAN', iptrw);
RegisterProperty('CURSOR', 'TCURSOR', iptrw); RegisterProperty('CURSOR', 'TCURSOR', iptrw);
RegisterProperty('BiDiMode','TBiDiMode',iptrw);
{$IFNDEF PS_MINIVCL} {$IFNDEF PS_MINIVCL}
RegisterMethod('function Dragging: Boolean;'); RegisterMethod('function Dragging: Boolean;');
@ -133,6 +134,7 @@ begin
Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble,' + Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble,' +
'ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum,ssScroll,ssTriple,ssQuad)'); 'ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum,ssScroll,ssTriple,ssQuad)');
{$ENDIF} {$ENDIF}
cl.AddTypeS('TBiDiMode','(bdLeftToRight,bdRightToLeft,bdRightToLeftNoAlign,bdRightToLeftReadingOnly)');
Cl.addTypeS('TShiftState','set of TEShiftState'); Cl.addTypeS('TShiftState','set of TEShiftState');
cl.AddTypeS('TMouseButton', '(mbLeft, mbRight, mbMiddle)'); cl.AddTypeS('TMouseButton', '(mbLeft, mbRight, mbMiddle)');
cl.AddTypeS('TDragMode', '(dmManual, dmAutomatic)'); cl.AddTypeS('TDragMode', '(dmManual, dmAutomatic)');

View File

@ -51,6 +51,8 @@ procedure TCONTROLENABLED_W(Self: TCONTROL; T: BOOLEAN); begin Self.ENABLED := T
procedure TCONTROLENABLED_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.ENABLED; end; procedure TCONTROLENABLED_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.ENABLED; end;
procedure TControlCaption_W(Self: TCONTROL; T: String); begin Self.Caption := T; end; procedure TControlCaption_W(Self: TCONTROL; T: String); begin Self.Caption := T; end;
procedure TControlCaption_R(Self: TCONTROL; var T: String); begin T := Self.Caption; end; procedure TControlCaption_R(Self: TCONTROL; var T: String); begin T := Self.Caption; end;
procedure TControlBiDiMode_W(Self: TCONTROL; T: TBiDiMode); begin Self.BiDiMode := T; end;
procedure TControlBiDiMode_R(Self: TCONTROL; var T: TBiDiMode); begin T := Self.BiDiMode; end;
procedure TControlBeginDrag(Self : TControl;Immediate : boolean); begin self.BeginDrag(Immediate); end; procedure TControlBeginDrag(Self : TControl;Immediate : boolean); begin self.BeginDrag(Immediate); end;
procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter); procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter);
@ -75,6 +77,7 @@ begin
RegisterPropertyHelper(@TControlVisibleR, @TControlVisibleW, 'VISIBLE'); RegisterPropertyHelper(@TControlVisibleR, @TControlVisibleW, 'VISIBLE');
RegisterPropertyHelper(@TCONTROLENABLED_R, @TCONTROLENABLED_W, 'ENABLED'); RegisterPropertyHelper(@TCONTROLENABLED_R, @TCONTROLENABLED_W, 'ENABLED');
RegisterPropertyHelper(@TControlCaption_R,@TControlCaption_W,'CAPTION'); RegisterPropertyHelper(@TControlCaption_R,@TControlCaption_W,'CAPTION');
RegisterPropertyHelper(@TControlBiDiMode_R,@TControlBiDiMode_W,'BiDiMode');
RegisterPropertyHelper(@TControlParentR, @TControlParentW, 'PARENT'); RegisterPropertyHelper(@TControlParentR, @TControlParentW, 'PARENT');
{$IFNDEF PS_MINIVCL} {$IFNDEF PS_MINIVCL}