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

cursor management updated:

Browse Source 
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor

git-svn-id: trunk@5398 -
This commit is contained in:
micha 2004-04-11 10:19:28 +00:00
parent d6d3a9ea40
commit 5effa0b10e
10 changed files with 107 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lcl/controls.pp
View File

@ -1710,7 +1710,8 @@ implementation
uses
Forms, // the circle can't be broken without breaking Delphi compatibility
Math; // Math is in RTL and only a few functions are used.
Math, // Math is in RTL and only a few functions are used.
WSControls;
var
// The interface knows, which TWinControl has the capture. This stores
@ -2241,6 +2242,11 @@ end.
{ =============================================================================
$Log$
Revision 1.195 2004/04/11 10:19:28 micha
cursor management updated:
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor
Revision 1.194 2004/04/09 23:52:01 mattias
fixed hiding uninitialized controls

12
lcl/include/control.inc
View File

@ -1798,12 +1798,7 @@ begin
if FCursor <> Value
then begin
FCursor := Value;
// This should not be called if it is already set to VALUE but if
// it's not created when it's set, and you set it again it skips this,
// so for now I do it this way.
// later, I'll create the cursor in the CreateComponent
// (or something like that)
if not(csDesigning in ComponentState) then CNSendMessage(LM_SETCURSOR, Self, nil);
TWSControlClass(WidgetSetClass).SetCursor(Self, Value);
end;
end;
@ -2880,6 +2875,11 @@ end;
{ =============================================================================
$Log$
Revision 1.182 2004/04/11 10:19:28 micha
cursor management updated:
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor
Revision 1.181 2004/04/10 17:58:56 mattias
implemented mainunit hints for include files

17
lcl/include/screen.inc
View File

@ -374,26 +374,9 @@ end;
procedure TScreen.SetCursor(const AValue: TCursor);
------------------------------------------------------------------------------}
procedure TScreen.SetCursor(const AValue: TCursor);
//var
//MousePos: TPoint;
//Handle: HWND;
//Code: Longint;
begin
if AValue <> Cursor then begin
FCursor := AValue;
{if AValue = crDefault then begin
// Reset the cursor to the default by sending a WM_SETCURSOR to the
// window under the cursor
GetCursorPos(MousePos);
Handle := WindowFromPoint(MousePos);
if (Handle <> 0) and
(GetWindowThreadProcessId(Handle, nil) = GetCurrentThreadId) then
begin
Code := SendMessage(Handle, WM_NCHITTEST, 0, LongInt(PointToSmallPoint(P)));
SendMessage(Handle, WM_SETCURSOR, Handle, MakeLong(Code, WM_MOUSEMOVE));
Exit;
end;
end;}
LCLIntf.SetCursor(Cursors[FCursor]);
end;
Inc(FCursorCount);

21
lcl/interfaces/win32/win32callback.inc
View File

@ -286,6 +286,11 @@ Begin
Assert(False, 'Trace:WindowProc - Getting Object With Callback Procedure');
OwnerObject := TObject(GetProp(Window, 'Wincontrol'));
if OwnerObject is TWinControl then begin
TheWinControl := TWinControl(OwnerObject);
end else begin
TheWinControl := nil;
end;
Assert(False, 'Trace:WindowProc - Getting Callback Object');
Assert(False, 'Trace:WindowProc - Checking Proc');
@ -736,6 +741,14 @@ Begin
LMMouse.Result := 0;
End;
End;
WM_SETCURSOR:
begin
if (TheWinControl <> nil) and (TheWinControl.Cursor <> crDefault) then
begin
Windows.SetCursor(Windows.LoadCursor(0, LclCursorToWin32CursorMap[TheWinControl.Cursor]));
WinProcess := false;
end;
end;
WM_SETFOCUS:
Begin
LMessage.Msg := LM_SETFOCUS;
@ -849,8 +862,7 @@ Begin
Msg := LM_NULL;
end;
end;
if OwnerObject is TWinControl then begin
TheWinControl:=TWinControl(OwnerObject);
if TheWinControl <> nil then begin
{$IFDEF VerboseSizeMsg}
writeln('Win32CallBack WM_MOVE ',TheWinControl.Name,':',TheWinControl.ClassName,
' NewPos=',XPos,',',YPos);
@ -1126,6 +1138,11 @@ end;
{
$Log$
Revision 1.100 2004/04/11 10:19:28 micha
cursor management updated:
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor
Revision 1.99 2004/04/10 17:54:52 micha
- added: [win32] mousewheel default handler sends scrollbar messages
- fixed: lmsetcursor; partial todo

42
lcl/interfaces/win32/win32int.pp
View File

@ -40,6 +40,38 @@ Uses
ExtCtrls, Forms, GraphMath, GraphType, InterfaceBase, LCLIntf, LCLType,
LMessages, StdCtrls, SysUtils, VCLGlobals, Win32Def, Graphics, Menus;
const
IDC_ARROW = MakeIntResource(32512);
IDC_IBEAM = MakeIntResource(32513);
IDC_WAIT = MakeIntResource(32514);
IDC_CROSS = MakeIntResource(32515);
IDC_UPARROW = MakeIntResource(32516);
IDC_SIZE = MakeIntResource(32640);
IDC_ICON = MakeIntResource(32641);
IDC_SIZENWSE = MakeIntResource(32642);
IDC_SIZENESW = MakeIntResource(32643);
IDC_SIZEWE = MakeIntResource(32644);
IDC_SIZENS = MakeIntResource(32645);
IDC_SIZEALL = MakeIntResource(32646);
IDC_NO = MakeIntResource(32648);
IDC_HAND = MakeIntResource(32649);
IDC_APPSTARTING = MakeIntResource(32650);
IDC_HELP = MakeIntResource(32651);
IDC_NODROP = MakeIntResource(32767);
IDC_DRAG = MakeIntResource(32766);
IDC_HSPLIT = MakeIntResource(32765);
IDC_VSPLIT = MakeIntResource(32764);
IDC_MULTIDRAG = MakeIntResource(32763);
IDC_SQLWAIT = MakeIntResource(32762);
IDC_HANDPT = MakeIntResource(32761);
LclCursorToWin32CursorMap: array[crLow..crHigh] of PChar = (
IDC_SIZEALL, IDC_HANDPT, IDC_HELP, IDC_APPSTARTING, IDC_NO, IDC_SQLWAIT,
IDC_MULTIDRAG, IDC_VSPLIT, IDC_HSPLIT, IDC_NODROP, IDC_DRAG, IDC_WAIT,
IDC_UPARROW, IDC_SIZEWE, IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW, IDC_SIZE,
IDC_IBEAM, IDC_CROSS, IDC_ARROW, IDC_ARROW, IDC_ARROW);
Type
{ Virtual alignment-control record }
TAlignment = Record
@ -78,7 +110,6 @@ Type
Procedure ResizeChild(Sender: TWinControl; Left, Top, Width, Height: Integer);
Procedure AssignSelf(Window: HWnd; Data: Pointer);
Procedure ReDraw(Child: TObject);
Procedure LmSetCursor(Sender: TObject; Data: Pointer);
Procedure SetLimitText(Window: HWND; Limit: Word);
Procedure ShowHide(Sender: TObject);
@ -161,7 +192,7 @@ Uses
// Win32WSCheckLst,
// Win32WSCListBox,
// Win32WSComCtrls,
// Win32WSControls,
Win32WSControls,
// Win32WSDbCtrls,
// Win32WSDBGrids,
// Win32WSDialogs,
@ -199,7 +230,7 @@ Type
TMsgArray = Array[0..1] Of Integer;
{$ENDIF}
Const
const
BOOL_RESULT: Array[Boolean] Of String = ('False', 'True');
ClsName : array[0..20] of char = 'LazarusForm'#0;
ToolBtnClsName : array[0..20] of char = 'ToolbarButton'#0;
@ -224,6 +255,11 @@ End.
{ =============================================================================
$Log$
Revision 1.77 2004/04/11 10:19:28 micha
cursor management updated:
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor
Revision 1.76 2004/04/10 17:54:52 micha
- added: [win32] mousewheel default handler sends scrollbar messages
- fixed: lmsetcursor; partial todo

64
lcl/interfaces/win32/win32object.inc
View File

@ -422,8 +422,6 @@ Begin
Assert(False, Format('Trace: [TWin32WidgetSet.IntSendMessage3] %s --> Show/Hide', [Sender.ClassName]));
ShowHide(Sender);
End;
LM_SETCURSOR:
LmSetCursor(Sender, Data);
LM_SETLABEL:
SetLabel(Sender, Data);
LM_GETVALUE:
@ -1741,62 +1739,6 @@ begin
end;
end;
const
IDC_ARROW = MakeIntResource(32512);
IDC_IBEAM = MakeIntResource(32513);
IDC_WAIT = MakeIntResource(32514);
IDC_CROSS = MakeIntResource(32515);
IDC_UPARROW = MakeIntResource(32516);
IDC_SIZE = MakeIntResource(32640);
IDC_ICON = MakeIntResource(32641);
IDC_SIZENWSE = MakeIntResource(32642);
IDC_SIZENESW = MakeIntResource(32643);
IDC_SIZEWE = MakeIntResource(32644);
IDC_SIZENS = MakeIntResource(32645);
IDC_SIZEALL = MakeIntResource(32646);
IDC_NO = MakeIntResource(32648);
IDC_HAND = MakeIntResource(32649);
IDC_APPSTARTING = MakeIntResource(32650);
IDC_HELP = MakeIntResource(32651);
IDC_NODROP = MakeIntResource(32767);
IDC_DRAG = MakeIntResource(32766);
IDC_HSPLIT = MakeIntResource(32765);
IDC_VSPLIT = MakeIntResource(32764);
IDC_MULTIDRAG = MakeIntResource(32763);
IDC_SQLWAIT = MakeIntResource(32762);
IDC_HANDPT = MakeIntResource(32761);
LclCursorToWin32CursorMap: array[crLow..crHigh] of PChar = (
IDC_SIZEALL, IDC_HANDPT, IDC_HELP, IDC_APPSTARTING, IDC_NO, IDC_SQLWAIT,
IDC_MULTIDRAG, IDC_VSPLIT, IDC_HSPLIT, IDC_NODROP, IDC_DRAG, IDC_WAIT,
IDC_UPARROW, IDC_SIZEWE, IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW, IDC_SIZE,
IDC_IBEAM, IDC_CROSS, IDC_ARROW, IDC_ARROW, IDC_ARROW);
{------------------------------------------------------------------------------
Method: TWin32WidgetSet.LmSetCursor
Params: Sender - the control which invoked this method
Returns: Nothing
Sets the cursor for a window
WARNING: Sender will be casted to TControl, CLEANUP!
------------------------------------------------------------------------------}
Procedure TWin32WidgetSet.LmSetCursor(Sender: TObject; Data: Pointer);
Var
Cursor: PChar;
Begin
Assert(False, 'Trace:TWin32WidgetSet.LmSetCursor - Start');
Assert(False, Format('Trace:TWin32WidgetSet.LmSetCursor - Sender --> %S', [Sender.ClassName]));
Assert(False, 'Trace:TWin32WidgetSet.LmSetCursor - Getting the cursor');
if Data = nil then
Data := Pointer(Integer(crDefault));
Cursor := LclCursorToWin32CursorMap[Integer(Data)];
Assert(False, 'Trace:TWin32WidgetSet.LmSetCursor - Loading the cursor');
Windows.SetCursor(Windows.LoadCursor(0, Cursor));
Assert(False, 'Trace:TWin32WidgetSet.LmSetCursor - Exit');
End;
{------------------------------------------------------------------------------
Method: TWin32WidgetSet.ResizeChild
Params: Sender - the object which invoked this function
@ -2663,7 +2605,6 @@ End;
------------------------------------------------------------------------------}
Function TWin32WidgetSet.SetValue(Sender: TObject; Data: Pointer): Integer;
Var
Cur: PChar;
Handle: HWnd;
ST: SystemTime;
@ -3028,6 +2969,11 @@ End;
{
$Log$
Revision 1.186 2004/04/11 10:19:28 micha
cursor management updated:
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor
Revision 1.185 2004/04/11 07:00:30 micha
speedup: don't redraw menubar if form is being destroyed

6
lcl/interfaces/win32/win32winapi.inc
View File

@ -1434,6 +1434,7 @@ begin
WindowHandle, HMENU(nil), HInstance, nil);
Windows.SetProp(OverlayWindow, 'DefWndProc', Windows.SetWindowLong(
OverlayWindow, GWL_WNDPROC, LongInt(@OverlayWindowProc)));
Windows.SetProp(OverlayWindow, 'Wincontrol', Windows.GetProp(WindowHandle, 'Wincontrol'));
Windows.SetProp(WindowHandle, 'Overlay', OverlayWindow);
end;
Result := Windows.GetDC(OverlayWindow);
@ -2974,6 +2975,11 @@ end;
{ =============================================================================
$Log$
Revision 1.107 2004/04/11 10:19:28 micha
cursor management updated:
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor
Revision 1.106 2004/04/10 17:54:52 micha
- added: [win32] mousewheel default handler sends scrollbar messages
- fixed: lmsetcursor; partial todo

13
lcl/interfaces/win32/win32wscontrols.pp
View File

@ -33,7 +33,7 @@ uses
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
// Controls,
Controls,
////////////////////////////////////////////////////
WSControls, WSLCLClasses;
@ -53,6 +53,7 @@ type
private
protected
public
class procedure SetCursor(AControl: TControl; ACursor: TCursor); override;
end;
{ TWin32WSWinControl }
@ -90,6 +91,14 @@ type
implementation
uses
Windows, Win32Int;
procedure TWin32WSControl.SetCursor(AControl: TControl; ACursor: TCursor);
begin
Windows.SetCursor(Windows.LoadCursor(0, LclCursorToWin32CursorMap[ACursor]));
end;
initialization
////////////////////////////////////////////////////
@ -99,7 +108,7 @@ initialization
// which actually implement something
////////////////////////////////////////////////////
// RegisterWSComponent(TDragImageList, TWin32WSDragImageList);
// RegisterWSComponent(TControl, TWin32WSControl);
RegisterWSComponent(TControl, TWin32WSControl);
// RegisterWSComponent(TWinControl, TWin32WSWinControl);
// RegisterWSComponent(TGraphicControl, TWin32WSGraphicControl);
// RegisterWSComponent(TCustomControl, TWin32WSCustomControl);

22
lcl/lmessages.pp
View File

@ -82,8 +82,6 @@ const
LM_INSERTTOOLBUTTON = LM_ComUser+46;
LM_DELETETOOLBUTTON = LM_ComUser+47;
//LM_SetCursor = LM_ComUser+48; We define this later for Windows compatability.
LM_IMAGECHANGED = LM_ComUser+49;
LM_LAYOUTCHANGED = LM_ComUser+50;
LM_BTNDEFAULT_CHANGED = LM_ComUser+51;
@ -299,7 +297,6 @@ const
LM_SHOWWINDOW = $0018;
LM_CANCELMODE = $001F;
LM_SETCURSOR = $0020;
LM_DRAWITEM = $002B;
LM_MEASUREITEM = $002C;
LM_DELETEITEM = $002D;
@ -410,18 +407,6 @@ type
ColorDepth : Integer;
end;
{$if defined(ver1_0) or not(defined(win32))}
TLMSETCURSOR = record
Msg : Cardinal;
CursorWnd : HWND;
HitText : Word;
MouseMsg : Word;
Result : Longint;
end;
{$else}
TLMSetCursor = TWMSetCursor;
{$endif}
PLMScreenInit = ^TLMScreenInit;
TLMCanvasCreate = Record
@ -921,8 +906,6 @@ begin
LM_INSERTTOOLBUTTON :Result:='LM_INSERTTOOLBUTTON';
LM_DELETETOOLBUTTON :Result:='LM_DELETETOOLBUTTON';
//LM_SetCursor :Result:='LM_SetCursor'; a LM_ComUser+48; We define this later for Windows compatability.
LM_IMAGECHANGED :Result:='LM_IMAGECHANGED';
LM_LAYOUTCHANGED :Result:='LM_LAYOUTCHANGED';
LM_BTNDEFAULT_CHANGED :Result:='LM_BTNDEFAULT_CHANGED';
@ -1089,6 +1072,11 @@ end.
{
$Log$
Revision 1.62 2004/04/11 10:19:28 micha
cursor management updated:
- lcl notifies interface via WSControl.SetCursor of changes
- fix win32 interface to respond to wm_setcursor callback and set correct cursor
Revision 1.61 2004/04/04 17:10:05 marc
Patch from Andrew Haines

11
lcl/widgetset/wscontrols.pp
View File

@ -33,7 +33,7 @@ uses
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
// Controls,
Controls,
////////////////////////////////////////////////////
WSLCLClasses, WSImgList;
@ -53,8 +53,11 @@ type
private
protected
public
class procedure SetCursor(AControl: TControl; ACursor: TCursor); virtual;
end;
TWSControlClass = class of TWSControl;
{ TWSWinControl }
TWSWinControl = class(TWSControl)
@ -90,6 +93,10 @@ type
implementation
procedure TWSControl.SetCursor(AControl: TControl; ACursor: TCursor);
begin
end;
initialization
////////////////////////////////////////////////////
@ -99,7 +106,7 @@ initialization
// which actually implement something
////////////////////////////////////////////////////
// RegisterWSComponent(TDragImageList, TWSDragImageList);
// RegisterWSComponent(TControl, TWSControl);
RegisterWSComponent(TControl, TWSControl);
// RegisterWSComponent(TWinControl, TWSWinControl);
// RegisterWSComponent(TGraphicControl, TWSGraphicControl);
// RegisterWSComponent(TCustomControl, TWSCustomControl);