paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-04 20:20:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Modified patch from Andrew for MouseMove and MouseUp messages

Browse Source 
git-svn-id: trunk@7963 -
This commit is contained in:
marc 2005-10-12 22:22:02 +00:00
parent 3de2242d78
commit 82fb7d047d
6 changed files with 158 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lcl/interfaces/carbon/carbonint.pas
View File

@ -120,6 +120,7 @@ uses
CarbonWSStdCtrls,
// CarbonWSToolwin,
////////////////////////////////////////////////////
CarbonDef, CarbonProc,
Math, Buttons, StdCtrls, PairSplitter, ComCtrls, CListBox, Calendar, Arrow,
Spin, CommCtrl, ExtCtrls, FileCtrl, LResources;

85
lcl/interfaces/carbon/carbonprivatewindow.inc
View File

@ -65,40 +65,91 @@ var
Modifiers, ButtonState: UInt32;
MousePoint: HIPoint;
pt: FPCMacOSAll.Point;
begin
Window: WindowRef;
R: FPCMacOSAll.Rect;
Msg: TLMMouseMove;
Info:PWidgetInfo;
begin
GetGlobalMouse(Pt);
MousePoint.X := pt.h;
MousePoint.Y := pt.v;
// todo, convert to correct co-ordinates
Window := HIViewGetWindow(AControl);
GetWindowBounds(Window, kWindowStructureRgn, R);
MousePoint.X := pt.h - R.left;
MousePoint.Y := pt.v - R.Top;
HIViewConvertPoint(MousePoint, nil, AControl);
Modifiers := GetCurrentKeyModifiers;
ButtonState := GetCurrentButtonState;
Msg.Msg := LM_MOUSEMOVE;
Msg.XPos := Trunc(MousePoint.X);
Msg.YPos := Trunc(MousePoint.Y);
Info := GetWidgetInfo(AControl);
if Info = nil then begin
//AControl should be fine but if it isn't, default to the window
Info := GetWidgetInfo(Window);//HIViewGetFirstSubview(HiViewRef(AControl)));
end;
if Info <> nil
then DeliverMessage(Info^.LCLObject, Msg);
DebugLn('-- track, x:%d, y:%d, m:0x%x, b:0x%x', [Round(MousePoint.X), Round(MousePoint.Y), Modifiers, ButtonState]);
end;
function CarbonPrivateWindow_ControlTrack(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AInfo: PWidgetInfo): OSStatus; mwpascal;
AInfo: PWidgetInfo): OSStatus; mwpascal;
const
MSGKIND: array[1..3] of Integer = (LM_LBUTTONUP, LM_RBUTTONUP, LM_MBUTTONUP);
var
Control: ControlRef;
Modifiers, ButtonState: UInt32;
MousePoint: HIPoint;//QDPoint;
ActionUPP, OldActionUPP: ControlActionUPP;
pt: FPCMacOSAll.Point;
MouseButton: EventMouseButton;
Window: WindowRef;
R: FPCMacOSAll.Rect;
Msg: TLMMouseMove;
begin
DebugLn('-- Control track A');
GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil, SizeOf(Modifiers), nil, @Modifiers);
GetEventParameter(AEvent, kEventParamWindowMouseLocation, typeHIPoint, nil, SizeOf(MousePoint), nil, @MousePoint);
GetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP, nil, sizeof(ActionUPP), nil, @OldActionUPP);
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil, SizeOf(MouseButton), nil, @MouseButton);
ButtonState := GetCurrentEventButtonState;
ActionUPP := NewControlActionUPP(@TrackProgress);
SetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP, sizeof(ActionUPP), @ActionUPP);
Result := CallNextEventHandler(ANextHandler, AEvent);
// this does not return until the mouse is released
Result := CallNextEventHandler(ANextHandler, AEvent);
SetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP, sizeof(OldActionUPP), @OldActionUPP);
DisposeControlActionUPP(ActionUPP);
// now we will create a MouseUp message to send the LCL
Control := ControlRef(AInfo^.Widget);
GetGlobalMouse(Pt);
Window := HIViewGetWindow(Control);
GetWindowBounds(Window, kWindowStructureRgn, R);
MousePoint.X := pt.h - R.left;
MousePoint.Y := pt.v - R.Top;
HIViewConvertPoint(MousePoint, nil, Control);
Modifiers := GetCurrentKeyModifiers;
ButtonState := GetCurrentButtonState;
if (MouseButton >= Low(MSGKIND))
and (MouseButton <= High(MSGKIND))
then Msg.Msg := MSGKIND[MouseButton];
Msg.XPos := Trunc(MousePoint.X);
Msg.YPos := Trunc(MousePoint.Y);
DeliverMessage(AInfo^.LCLObject, Msg);
DebugLn('-- Control track B, x:%d, y:%d, m:0x%x, b:0x%x', [Round(MousePoint.X), Round(MousePoint.Y), Modifiers, ButtonState]);
end;
@ -108,6 +159,8 @@ function CarbonPrivateWindow_MouseProc(ANextHandler: EventHandlerCallRef;
var
Control: ControlRef; // the control we are dealing with
// or the rootcontrol if none found
Info: PWidgetInfo; // the info specific to the mouse event
// or the window's widgetinfo if none found
//
// helper functions used commonly
@ -155,8 +208,6 @@ var
MousePoint: TPoint;
Msg: ^TLMMouse;
Spec: EventTypeSpec;
pt: FPCMacOSAll.Point;
mtr: MouseTrackingResult;
begin
DebugLN('-- mouse down --');
Msg := @AMsg;
@ -181,12 +232,7 @@ var
Spec := MakeEventSpec(kEventClassControl, kEventControlTrack);
InstallControlEventHandler(Control, RegisterEventHandler(@CarbonPrivateWindow_ControlTrack),
1, @Spec, nil, nil);
// repeat
// TrackMouseLocation(nil, Pt, mtr);
// DebugLn('Mouse track, x:%d, y:%d, m:0x%x', [Round(pt.h), Round(pt.v), mtr]);
// until mtr = kMouseTrackingMouseUp;
1, @Spec, Info, nil);
end;
@ -250,7 +296,6 @@ var
end;
EventKind: UInt32;
Root: ControlRef;
Info: PWidgetInfo;
begin
FillChar(Msg, SizeOf(Msg), 0);
@ -279,11 +324,12 @@ begin
case EventKind of
kEventMouseDown : HandleMouseDownEvent(Msg);
kEventMouseUp : HandleMouseUpEvent(Msg);
kEventMouseMoved : HandleMouseMovedEvent(Msg);
kEventMouseDragged : HandleMouseDraggedEvent(Msg);
kEventMouseMoved,// : HandleMouseMovedEvent(Msg);
kEventMouseDragged : HandleMouseMovedEvent(Msg);//HandleMouseDraggedEvent(Msg);
//For the enter and exit events tracking must be enabled
//tracking is enabled by defining a rect that you want to track
// SEE FPCMacOSAll line 134390
// TODO: Tracking
kEventMouseEntered : Msg.Message.Msg := CM_MOUSEENTER;
kEventMouseExited : Msg.Message.Msg := CM_MOUSELEAVE;
@ -291,6 +337,7 @@ begin
kEventMouseWheelMoved : HandleMouseWheelEvent(Msg);
end;
// Msg is set in the Appropriate HandleMousexxx procedure
if DeliverMessage(Info^.LCLObject, Msg) = 0 then begin
Result := EventNotHandledErr; //CallNextEventHandler(ANextHandler, AEvent);
end

54
lcl/interfaces/carbon/carbonwinapi.inc
View File

@ -302,8 +302,15 @@ begin
end;
function TCarbonWidgetSet.GetActiveWindow: HWND;
var
Window: WindowRef;
begin
Result:=inherited GetActiveWindow;
Result := 0;//Inherited GetFocus;
Window := GetWindowList;
while (Window <> nil) and not IsWindowActive(Window) do begin
Window := GetNextWindow(Window);
end;
Result := HWND(Window);
end;
function TCarbonWidgetSet.GetBitmapBits(Bitmap: HBITMAP; Count: Longint;
@ -340,16 +347,30 @@ begin
Result:=inherited GetCharABCWidths(DC, p2, p3, ABCStructs);
end;
function TCarbonWidgetSet.GetClientBounds(handle: HWND; var ARect: TRect
): Boolean;
function TCarbonWidgetSet.GetClientBounds(handle: HWND; var ARect: TRect): Boolean;
var
Info: PWidgetInfo;
WinControl: TWinControl;
begin
Result:=inherited GetClientBounds(handle, ARect);
Result := False;
Info := GetwidgetInfo(Pointer(Handle));
if Info = nil then Exit;
WinControl := TWinControl(Info^.LCLObject);
Result := TCarbonWSWinControlClass(WinControl.WidgetSetClass).GetClientBounds(WinControl, ARect);
end;
function TCarbonWidgetSet.GetClientRect(handle: HWND; var ARect: TRect
): Boolean;
function TCarbonWidgetSet.GetClientRect(handle: HWND; var ARect: TRect): Boolean;
var
Info: PWidgetInfo;
WinControl: TWinControl;
begin
Result:=inherited GetClientRect(handle, ARect);
Result := False;
Info := GetwidgetInfo(Pointer(Handle));
if Info = nil then Exit;
WinControl := TWinControl(Info^.LCLObject);
Result := TCarbonWSWinControlClass(WinControl.WidgetSetClass).GetClientRect(WinControl, ARect);
end;
function TCarbonWidgetSet.GetClipBox(DC: hDC; lpRect: PRect): Longint;
@ -419,9 +440,19 @@ begin
end;
function TCarbonWidgetSet.GetFocus: HWND;
var
Control: ControlRef;
Window: WindowRef;
begin
Result:=inherited GetFocus;
DebugLn('TODO: TCarbonWidgetSet.GetFocus');
Result := 0;//Inherited GetFocus;
Window := GetWindowList;
while (Window <> nil) and not IsWindowActive(Window) do begin
Window := GetNextWindow(Window);
end;
if Window = nil then Exit;
Control := nil;
GetKeyboardFocus(Window, Control);
Result := HWND(Control);
end;
function TCarbonWidgetSet.GetFontLanguageInfo(DC: HDC): DWord;
@ -774,7 +805,10 @@ end;
function TCarbonWidgetSet.SetActiveWindow(Handle: HWND): HWND;
begin
Result:=inherited SetActiveWindow(Handle);
Result := 0;
if Handle = 0 then exit;
Result := GetActiveWindow;
if ActivateWindow(WindowRef(Handle), True) <> NoErr then Result := 0;
end;
function TCarbonWidgetSet.SetBkColor(DC: HDC; Color: TColorRef): TColorRef;

35
lcl/interfaces/carbon/carbonwscontrols.pp
View File

@ -28,7 +28,7 @@ interface
uses
// libs
FPCMacOSAll, CarbonUtils, CarbonExtra,
FPCMacOSAll, CarbonUtils, CarbonExtra, Classes,
// LCL
Controls, LCLType, LMessages, LCLProc,
// widgetset
@ -56,13 +56,16 @@ type
{ TCarbonWSWinControl }
TCarbonWSWinControlClass = class of TCarbonWSWincontrol;
TCarbonWSWinControl = class(TWSWinControl)
private
protected
public
class function GetText(const AWinControl: TWinControl; var AText: String): Boolean; override;
class procedure SetText(const AWinControl: TWinControl; const AText: String); override;
class procedure DestroyHandle(const AWinControl: TWinControl); override;
class function GetClientBounds(const AWincontrol: TWinControl; var ARect: TRect): Boolean; override;
class function GetClientRect(const AWincontrol: TWinControl; var ARect: TRect): Boolean; override;
class function GetText(const AWinControl: TWinControl; var AText: String): Boolean; override;
class procedure SetText(const AWinControl: TWinControl; const AText: String); override;
end;
{ TCarbonWSGraphicControl }
@ -141,6 +144,32 @@ begin
DisposeControl(ControlRef(AWinControl.Handle));
end;
function TCarbonWSWinControl.GetClientBounds(const AWincontrol: TWinControl;
var ARect: TRect): Boolean;
var
AHiRect: HIRect;
begin
Result := HIViewGetBounds(HIViewRef(AWinControl.Handle), AHiRect) = 0;
if not Result then Exit;
ARect.Top := Trunc(AHiRect.Origin.y);
ARect.Left := Trunc(AHiRect.Origin.x);
ARect.Right := ARect.Left + Trunc(AHiRect.size.width);
ARect.Bottom := ARect.Top + Trunc(AHIRect.size.height);
end;
function TCarbonWSWinControl.GetClientRect(const AWincontrol: TWinControl;
var ARect: TRect): Boolean;
var
AHiRect: HIRect;
begin
Result := HIViewGetBounds(HIViewRef(AWinControl.Handle), AHiRect) = 0;
if not Result then Exit;
ARect.Top := 0;//AHiRect.Origin.y;
ARect.Left := 0;//AHiRect.Origin.x;
ARect.Right := ARect.Left + Trunc(AHiRect.size.width);
ARect.Bottom := ARect.Top + Trunc(AHIRect.size.height);
end;
initialization
////////////////////////////////////////////////////

2
lcl/interfaces/carbon/carbonwsforms.pp
View File

@ -72,7 +72,7 @@ type
end;
{ TCarbonWSCustomForm }
TCarbonWSCustomFormClass = class of TCarbonWSCustomForm;
TCarbonWSCustomForm = class(TWSCustomForm)
private
protected

14
lcl/widgetset/wscontrols.pp
View File

@ -73,6 +73,8 @@ type
{ TWSWinControl }
TWSWinControl = class(TWSControl)
class function GetClientBounds(const AWincontrol: TWinControl; var ARect: TRect): Boolean; virtual;
class function GetClientRect(const AWincontrol: TWinControl; var ARect: TRect): Boolean; virtual;
class procedure GetPreferredSize(const AWinControl: TWinControl; var PreferredWidth, PreferredHeight: integer); virtual;
class function GetText(const AWinControl: TWinControl; var AText: String): Boolean; virtual;
class function GetTextLen(const AWinControl: TWinControl; var ALength: Integer): Boolean; virtual;
@ -149,6 +151,18 @@ procedure TWSWinControl.DestroyHandle(const AWinControl: TWinControl);
begin
end;
function TWSWinControl.GetClientBounds(const AWincontrol: TWinControl; var ARect: TRect): Boolean;
begin
// for now default to the WinAPI version
Result := WidgetSet.GetClientBounds(AWincontrol.Handle, ARect);
end;
function TWSWinControl.GetClientRect(const AWincontrol: TWinControl; var ARect: TRect): Boolean;
begin
// for now default to the WinAPI version
Result := WidgetSet.GetClientRect(AWincontrol.Handle, ARect);
end;
{------------------------------------------------------------------------------
Function: TWSWinControl.GetText
Params: Sender: The control to retrieve the text from