From b3f981c48becc3be4d71b9ed30d3f9b3adc59441 Mon Sep 17 00:00:00 2001 From: marc Date: Mon, 15 Jan 2007 00:53:09 +0000 Subject: [PATCH] * Modified patch from Paul Ishenin implementing cursors git-svn-id: trunk@10446 - --- .gitattributes | 9 ++ lcl/cursors.lrs | 101 +++++++++++++++++++++ lcl/forms.pp | 17 ++-- lcl/graphics.pp | 54 ++++++++++++ lcl/images/cursors/build.bat | 1 + lcl/images/cursors/cur_12.cur | Bin 0 -> 326 bytes lcl/images/cursors/cur_13.cur | Bin 0 -> 326 bytes lcl/images/cursors/cur_14.cur | Bin 0 -> 326 bytes lcl/images/cursors/cur_15.cur | Bin 0 -> 326 bytes lcl/images/cursors/cur_16.cur | Bin 0 -> 326 bytes lcl/images/cursors/cur_17.cur | Bin 0 -> 326 bytes lcl/images/cursors/cur_21.cur | Bin 0 -> 326 bytes lcl/include/control.inc | 2 +- lcl/include/intfbaselcl.inc | 5 ++ lcl/include/intfbasewinapi.inc | 10 +++ lcl/include/lclintf.inc | 5 ++ lcl/include/lclintfh.inc | 1 + lcl/include/screen.inc | 102 +++++++++++----------- lcl/include/winapi.inc | 10 +++ lcl/include/winapih.inc | 3 + lcl/interfaces/gtk/gtkglobals.pp | 8 +- lcl/interfaces/gtk/gtkint.pp | 42 ++------- lcl/interfaces/gtk/gtklclintfh.inc | 2 + lcl/interfaces/gtk/gtkobject.inc | 5 ++ lcl/interfaces/gtk/gtkproc.inc | 111 ++++++++++++++++++------ lcl/interfaces/gtk/gtkproc.pp | 16 +++- lcl/interfaces/gtk/gtkwscontrols.pp | 5 +- lcl/interfaces/win32/win32callback.inc | 2 +- lcl/interfaces/win32/win32lclintf.inc | 30 +++++++ lcl/interfaces/win32/win32lclintfh.inc | 4 +- lcl/interfaces/win32/win32object.inc | 4 +- lcl/interfaces/win32/win32winapi.inc | 26 +++++- lcl/interfaces/win32/win32winapih.inc | 2 + lcl/interfaces/win32/win32wscontrols.pp | 7 +- lcl/intfgraphics.pas | 70 ++++++++++++--- lcl/lcltype.pp | 16 ++++ lcl/widgetset/wscontrols.pp | 4 +- 37 files changed, 519 insertions(+), 155 deletions(-) create mode 100644 lcl/cursors.lrs create mode 100644 lcl/images/cursors/build.bat create mode 100644 lcl/images/cursors/cur_12.cur create mode 100644 lcl/images/cursors/cur_13.cur create mode 100644 lcl/images/cursors/cur_14.cur create mode 100644 lcl/images/cursors/cur_15.cur create mode 100644 lcl/images/cursors/cur_16.cur create mode 100644 lcl/images/cursors/cur_17.cur create mode 100644 lcl/images/cursors/cur_21.cur diff --git a/.gitattributes b/.gitattributes index 46069acc93..2afed6fc6e 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2099,6 +2099,7 @@ lcl/colorbox.pas svneol=native#text/pascal lcl/comctrls.pp svneol=native#text/pascal lcl/commctrl.pp svneol=native#text/pascal lcl/controls.pp svneol=native#text/pascal +lcl/cursors.lrs svneol=native#text/pascal lcl/customtimer.pas svneol=native#text/pascal lcl/dbactns.pp svneol=native#text/pascal lcl/dbctrls.pp svneol=native#text/pascal @@ -2147,6 +2148,14 @@ lcl/images/btncalcpm.xpm -text svneol=native#image/x-xpixmap lcl/images/btncalculator.xpm -text svneol=native#image/x-xpixmap lcl/images/btncalendar.xpm -text svneol=native#image/x-xpixmap lcl/images/btnseldir.xpm -text svneol=native#image/x-xpixmap +lcl/images/cursors/build.bat -text svneol=CRLF#application/x-bat +lcl/images/cursors/cur_12.cur -text svneol=unset#image/x-cursor +lcl/images/cursors/cur_13.cur -text svneol=unset#image/x-cursor +lcl/images/cursors/cur_14.cur -text svneol=unset#image/x-cursor +lcl/images/cursors/cur_15.cur -text svneol=unset#image/x-cursor +lcl/images/cursors/cur_16.cur -text svneol=unset#image/x-cursor +lcl/images/cursors/cur_17.cur -text svneol=unset#image/x-cursor +lcl/images/cursors/cur_21.cur -text svneol=unset#image/x-cursor lcl/images/dbnavcancel.xpm -text svneol=native#image/x-xpixmap lcl/images/dbnavdelete.xpm -text svneol=native#image/x-xpixmap lcl/images/dbnavedit.xpm -text svneol=native#image/x-xpixmap diff --git a/lcl/cursors.lrs b/lcl/cursors.lrs new file mode 100644 index 0000000000..af9dc8b94c --- /dev/null +++ b/lcl/cursors.lrs @@ -0,0 +1,101 @@ +LazarusResources.Add('cur_12','CUR',[ + #0#0#2#0#1#0' '#0#0#3#0#2#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0 + +#1#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#24#0#0#0#24#0#0#0'0'#0#0#0'0'#0#0#0'`'#0#0#8'`'#0#0#12#192#0#0#14#192 + +#0#0#15#192#0#0#15#248#0#0#15#240#0#0#15#224#0#0#15#192#0#0#15#128#0#0#15#0#0 + +#0#14#0#0#0'm'#192#0#0'k'#192#0#0'g'#192#0#0'o'#192#0#0''#192#0#0#0#0#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#231 + +#255#255#255#195#255#255#255#195#255#255#255#135#255#255#239#135#255#255#231 + +#15#255#255#226#15#255#255#224#31#255#255#224#31#255#255#224#3#255#255#224#3 + +#255#255#224#7#255#255#224#15#255#255#224#31#255#255#224'?'#255#255#224'' + +#255#255#0#31#255#255#0#31#255#255#0#31#255#255#0#31#255#255#0#31#255#255#0 + +#31#255#255#0#31#255#255 +]); +LazarusResources.Add('cur_13','CUR',[ + #0#0#2#0#1#0' '#0#0#2#0#2#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0 + +#1#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#240#0#0#6#12#0#0#24#3#0#0#18#1#0#0'"' + +#0#128#0'!'#0#128#0'A'#0'@'#0'@'#128'@'#0'@'#128'@'#0'@@@'#0'@@@'#0' '#128#0 + +' '#128#0#16#17#0#0#24#19#0#0#6#12#0#0#1#240#0#0#0#0#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#254#15#255#255#248#3#255#255#224#0#255 + +#255#193#240''#255#192#252''#255#136#254'?'#255#140'~?'#255#28''#31#255#30 + +'?'#31#255#30'?'#31#255#31#31#31#255#31#31#31#255#143#142'?'#255#143#142'?' + +#255#199#196''#255#193#192''#255#224#0#255#255#248#3#255#255#254#15#255#255 +]); +LazarusResources.Add('cur_14','CUR',[ + #0#0#2#0#1#0' '#0#0#15#0#15#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 + +#0#1#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#255#255#255 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#192#0 + +#0#2'@'#0#0#2'@'#0#0#2'@'#0#0'2L'#0#0'RJ'#0#0#146'I'#0#1#26'X'#128#2#2'@@'#1 + +#26'X'#128#0#146'I'#0#0'RJ'#0#0'2L'#0#0#2'@'#0#0#2'@'#0#0#2'@'#0#0#3#192#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#252'?'#255#255#252'?'#255#255#252'?'#255 + +#255#252'?'#255#255#204'3'#255#255#140'1'#255#255#12'0'#255#254#4' '#252#4 + +' ?'#254#4' '#255#12'0'#255#255#140'1'#255#255#204'3'#255#255#252'?'#255#255 + +#252'?'#255#255#252'?'#255#255#252'?'#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +]); +LazarusResources.Add('cur_15','CUR',[ + #0#0#2#0#1#0' '#0#0#15#0#15#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 + +#0#1#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#255#255#255 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#0#0#0#2#128#0#0#4'@'#0 + +#0#8' '#0#0#16#16#0#0#30#240#0#0#2#128#0#0#0#0#0#1#255#255#0#1#0#1#0#1#0#1#0 + +#1#255#255#0#0#0#0#0#0#2#128#0#0#30#240#0#0#16#16#0#0#8' '#0#0#4'@'#0#0#2#128 + +#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#254#255#255#255#252''#255#255#248'?'#255#255#240#31#255#255#224#15 + +#255#255#224#15#255#255#252''#255#255#255#255#255#254#0#0#255#254#0#0#255 + +#254#0#0#255#254#0#0#255#255#255#255#255#255#252''#255#255#224#15#255#255 + +#224#15#255#255#240#31#255#255#248'?'#255#255#252''#255#255#254#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255 +]); +LazarusResources.Add('cur_16','CUR',[ + #0#0#2#0#1#0' '#0#0#7#0#6#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0 + +#1#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#128#0#0#1#128#0#0#3#0#0 + +#0#3#0#0#0#6#0#0#0#134#0#0#0#204#0#0#0#236#0#0#0#252#0#0#0#255#128#0#0#255#0 + +#0#0#254#0#0#0#252#0#0#0#248#0#0#0#240#0#0#0#224#0#0#6#220#0#0#6#188#0#0#22 + +'|'#0#0#22#252#0#0'W'#252#0#0'P'#0#0#0'_'#240#0#0'@'#0#0#0''#192#0#0#0#0#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#254''#255#255#252'?'#255#255#252'?'#255#255#248''#255#254#248'' + +#255#254'p'#255#255#254'0'#255#255#254#1#255#255#254#1#255#255#254#0'?'#255 + +#254#0'?'#255#254#0''#255#254#0#255#255#254#1#255#255#254#3#255#255#254#7 + +#255#255#240#1#255#255#240#1#255#255#192#1#255#255#192#1#255#255#0#1#255#255 + +#0#1#255#255#0#1#255#255#0#7#255#255#0#7#255#255#0#31#255#255#0#31#255#255 +]); +LazarusResources.Add('cur_17','CUR',[ + #0#0#2#0#1#0' '#0#0#0#0#0#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0 + +#1#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#31#240#0#0#0#0#0#0#26#176#0#0#13'`'#0#0#7#192#0#0#3#128#0#0#1#0#0#0#0 + +#0#0#0#1#0#0#0#1#0#0#0#3#128#0#0#6#192#0#0#13'`'#0#0#31#240#0#0#0#0#0#0#31 + +#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255 + +#255#223#255#255#158'0'#255#255'm6'#255#255#221#183#255#255#189#183#255#255 + +'m'#183#255#255#158'w'#255#255#255#255#255#255#128#3#255#255#128#3#255#255 + +#128#3#255#255#192#7#255#255#192#7#255#255#224#15#255#255#240#31#255#255#248 + +'?'#255#255#252''#255#255#252''#255#255#248'?'#255#255#240#31#255#255#224 + +#15#255#255#192#7#255#255#192#7#255#255#128#3#255#255#128#3#255#255#128#3#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255 +]); +LazarusResources.Add('cur_21','CUR',[ + #0#0#2#0#1#0' '#0#0#6#0#1#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0 + +#1#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#248#0#0#3#248#0#0#7#252#0#0#15#252#0#0#15#254 + +#0#0#31#254#0#0';'#255#0#0'3'#255#0#0#3#253#0#0#3#253#0#0#3'l'#0#0#3'l'#0#0#3 + +'`'#0#0#3#0#0#0#3#0#0#0#3#0#0#0#3#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#254#3#255#255#252#3#255#255#248#3#255#255#240#1#255#255 + +#224#1#255#255#224#0#255#255#192#0#255#255#128#0''#255#128#0''#255#136#0'' + +#255#248#0''#255#248#0#255#255#248#1#255#255#248#3#255#255#248#31#255#255 + +#248''#255#255#248''#255#255#248''#255#255#252#255#255#255#255#255#255#255 +]); diff --git a/lcl/forms.pp b/lcl/forms.pp index f5c5112e37..5c50b212cc 100644 --- a/lcl/forms.pp +++ b/lcl/forms.pp @@ -39,7 +39,7 @@ interface uses Classes, SysUtils, TypInfo, Math, LCLStrConsts, LCLType, LCLProc, LCLIntf, InterfaceBase, LResources, GraphType, Graphics, Menus, LMessages, CustomTimer, - ActnList, ClipBrd, CustApp, HelpIntfs, LCLClasses, Controls; + ActnList, ClipBrd, CustApp, HelpIntfs, LCLClasses, Controls, maps; type TProcedure = procedure; @@ -706,7 +706,7 @@ type FActiveForm: TForm; FCursor: TCursor; FCursorCount: integer; - FCursorList: PCursorRec; + FCursorMap: TMap; FCustomForms: TList; FCustomFormsZOrdered: TList; FDefaultCursor: HCURSOR; @@ -721,10 +721,9 @@ type FOnActiveFormChange: TNotifyEvent; FPixelsPerInch : integer; FSaveFocusedList: TList; - procedure CreateCursors; - procedure DeleteCursor(Index: Integer); + procedure DeleteCursor(AIndex: Integer); procedure DestroyCursors; - function GetCursors(Index: Integer): HCURSOR; + function GetCursors(AIndex: Integer): HCURSOR; function GetCustomFormCount: Integer; function GetCustomFormZOrderCount: Integer; function GetCustomForms(Index: Integer): TCustomForm; @@ -737,7 +736,7 @@ type procedure AddForm(AForm: TCustomForm); procedure RemoveForm(AForm: TCustomForm); procedure SetCursor(const AValue: TCursor); - procedure SetCursors(Index: Integer; const AValue: HCURSOR); + procedure SetCursors(AIndex: Integer; const AValue: HCURSOR); procedure UpdateLastActive; procedure AddHandler(HandlerType: TScreenNotification; const Handler: TMethod; AsLast: Boolean); @@ -1539,6 +1538,8 @@ end; procedure FreeWidgetSet; begin //debugln('FreeWidgetSet'); + if Screen <> nil then + Screen.DestroyCursors; if Application=nil then exit; Application.Free; Application:=nil; @@ -1767,14 +1768,14 @@ end; //============================================================================== initialization + {$INCLUDE cursors.lrs} LCLProc.OwnerFormDesignerModifiedProc:=@IfOwnerIsFormThenDesignerModified; Screen:=TScreen.Create(nil); Application:=TApplication.Create(nil); {$IFDEF UseFCLDataModule} RegisterInitComponentHandler(TComponent,@InitResourceComponent); - {$ENDIF} - + {$ENDIF} finalization //DebugLn('forms.pp - finalization section'); LCLProc.OwnerFormDesignerModifiedProc:=nil; diff --git a/lcl/graphics.pp b/lcl/graphics.pp index 58949a11c5..a5850583a8 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -1294,10 +1294,22 @@ type procedure AddBitmap(Bitmap: TBitmap); { Note that Ownership passes to TIcon } end; + { TCursorImage } TCursorImage = class(TIcon) + private + FHotSpot: TPoint; + FCursorHandle: hCursor; + FOwnHandle: Boolean; + protected + function GetCursorHandle: hCursor; public + constructor Create; override; + destructor Destroy; override; class function GetFileExtensions: string; override; function LazarusResourceTypeValid(const ResourceType: string): boolean; override; + property HotSpot: TPoint read FHotSpot write FHotSpot; + property CursorHandle: hCursor read GetCursorHandle; + property OwnHandle: Boolean read FOwnHandle write FOwnHandle; end; function GraphicFilter(GraphicClass: TGraphicClass): string; @@ -1374,6 +1386,7 @@ function LazResourceXPMToPPChar(const ResourceName: string): PPChar; function ReadXPMFromStream(Stream: TStream; Size: integer): PPChar; function ReadXPMSize(XPM: PPChar; var Width, Height, ColorCount: integer ): boolean; +function LoadCursorFromLazarusResource(ACursorName: String): HCursor; var { Stores information about the current screen @@ -1434,6 +1447,17 @@ begin Result:='['+Result+']'; end; +function LoadCursorFromLazarusResource(ACursorName: String): HCursor; +var + CursorImage: TCursorImage; +begin + CursorImage := TCursorImage.Create; + CursorImage.LoadFromLazarusResource(ACursorName); + CursorImage.OwnHandle := False; + Result := CursorImage.CursorHandle; + CursorImage.Free; +end; + procedure Register; begin RegisterClasses([TBitmap,TPixmap,TPortableNetworkGraphic, @@ -1951,6 +1975,36 @@ begin (AnsiCompareText(ResourceType,'CUR')=0); end; +function TCursorImage.GetCursorHandle: hCursor; +var + IconInfo: TIconInfo; +begin + if FCursorHandle = 0 then + begin + IconInfo.fIcon := False; + IconInfo.xHotspot := HotSpot.X; + IconInfo.yHotSpot := HotSpot.Y; + IconInfo.hbmMask := MaskHandle; + IconInfo.hbmColor := Handle; + FCursorHandle := WidgetSet.CreateCursor(@IconInfo); + end; + Result := FCursorHandle; +end; + +constructor TCursorImage.Create; +begin + inherited Create; + FHotSpot := Point(0, 0); + FCursorHandle := 0; + FOwnHandle := True; +end; + +destructor TCursorImage.Destroy; +begin + if (FCursorHandle <> 0) and OwnHandle then + WidgetSet.DestroyCursor(FCursorHandle); +end; + procedure InterfaceFinal; begin //debugln('Graphics.InterfaceFinal'); diff --git a/lcl/images/cursors/build.bat b/lcl/images/cursors/build.bat new file mode 100644 index 0000000000..9f6461711a --- /dev/null +++ b/lcl/images/cursors/build.bat @@ -0,0 +1 @@ +lazres cursors.lrs cur_12.cur cur_13.cur cur_14.cur cur_15.cur cur_16.cur cur_17.cur cur_21.cur diff --git a/lcl/images/cursors/cur_12.cur b/lcl/images/cursors/cur_12.cur new file mode 100644 index 0000000000000000000000000000000000000000..13f3a457c5dee0be3d405a5c67a5632245f08b0e GIT binary patch literal 326 zcma*hF%E(-6vpwd5@FQIm5z)YzyuO5;^fR^9E@-<1`pyPJOIh_-@-sr2Ve7hZQpB~ zN;^4uuNbwHPOK_;v~Y|NW6WtXv$VLW6tk2#OZj`TpQIprNFDdCxZ#Q6g%RtXBf6u< k1ua7GhoA9rX8-6pSL2BASae`6(O_6=v@Jsc+E${$7cc~Lu>b%7 literal 0 HcmV?d00001 diff --git a/lcl/images/cursors/cur_13.cur b/lcl/images/cursors/cur_13.cur new file mode 100644 index 0000000000000000000000000000000000000000..63e0ff3ecc40f35d02adf91668e448f88d6f4774 GIT binary patch literal 326 zcmbV`F$%&^5JX=R&?ZDH2_hz?g@tx0EEK_W=skpQP_Xn$1}_qCV3|S~_nR`6&N90& z?CcJN1mrn3LlyyyfSJ)G*2cifG8$j0e~+ zEz=klNxPe*;JqG};V-;1>D8C&NP1M#`6ZQ&G;EyGqtj&NG@UqQvD4t)1O zFfBk}sWl7?TB{fsyjC(W^zCS1WLn?=qQQKSI7l8@JxD(e0CWRk@JIgte`Neb`2YVS eg8%=w2!MQ0|Br#e9z=urAaRg9vU(632LJ#es(nNN literal 0 HcmV?d00001 diff --git a/lcl/images/cursors/cur_15.cur b/lcl/images/cursors/cur_15.cur new file mode 100644 index 0000000000000000000000000000000000000000..f3e5bc45131b0c2badc6541cac08b3c9b3236847 GIT binary patch literal 326 zcma)$F%AMT3p0GAVyF~at87?v zEU*I(Qj-R$XgS87=TuW25$W`!v~ek|M%WJeq`_(Gy+yn2`^j&JoxBEcG6gFLn0An77YxtA#7TFwCJ%89mEgwnH;*OhCUZg!c zk2v9qVMM@Z&Jvx`0Bv0T8{Ralg6OesJF?Dr-A{B&TmgQ0;bD5pJ z-PyeZ5(E@Q0>dHz6X{$m#I+c74CN#7p!;_mvTVQ+!vOSRQ^iTyy`Bh1B z1O^)**G%4dJARia>U6sR literal 0 HcmV?d00001 diff --git a/lcl/images/cursors/cur_21.cur b/lcl/images/cursors/cur_21.cur new file mode 100644 index 0000000000000000000000000000000000000000..b2982dbdd3d15b48a8a6535d2b3017e8603f16f0 GIT binary patch literal 326 zcmaLRF%E+;3B!Vx-li1PariVzGWda>*{a)1Jc zt^-QN-hc+cLsY^brkz)@gyTu_SUS(6uEi2Py<`(gCLWcva*H1JTB-Lb)80Bre>h)8 hM(hRU0VBVe;|Ix|v-rQaVo1y}T-9HT+r)7h`vXURdI nil) and (P^.Index <> Index) do begin - Q := P; - P := P^.Next; - end; - if P <> nil then begin - DebugLn('ToDo: TScreen.DeleteCursor'); - //DestroyCursor(P^.Handle); - if Q = nil then - FCursorList := P^.Next - else - Q^.Next := P^.Next; - Dispose(P); - end; + if not FCursorMap.GetData(AIndex, ACursor) then Exit; + WidgetSet.DestroyCursor(ACursor); + FCursorMap.Delete(AIndex); end; {------------------------------------------------------------------------------ @@ -308,36 +291,41 @@ end; ------------------------------------------------------------------------------} procedure TScreen.DestroyCursors; var - P, Next: PCursorRec; - //Hdl: THandle; + Iterator: TMapIterator; + ACursor: HCURSOR; begin - P := FCursorList; - while P <> nil do begin - DebugLn('ToDo: TScreen.DeleteCursor'); - //DestroyCursor(P^.Handle); - Next := P^.Next; - Dispose(P); - P := Next; + Iterator := TMapIterator.Create(FCursorMap); + Iterator.First; + while not Iterator.EOM do + begin + Iterator.GetData(ACursor); + WidgetSet.DestroyCursor(ACursor); + Iterator.Next; end; + Iterator.Free; + FCursorMap.Clear; end; {------------------------------------------------------------------------------ function TScreen.GetCursors(Index: Integer): HCURSOR; ------------------------------------------------------------------------------} -function TScreen.GetCursors(Index: Integer): HCURSOR; -var - P: PCursorRec; +function TScreen.GetCursors(AIndex: Integer): HCURSOR; begin Result := 0; - if Index <> crNone then - begin - P := FCursorList; - while (P <> nil) and (P^.Index <> Index) do P := P^.Next; - if P = nil then - Result := FDefaultCursor - else - Result := P^.Handle; - end; + if AIndex = crNone then Exit; + if FCursorMap.GetData(AIndex, Result) then Exit; + + Result := FDefaultCursor; + if AIndex > crHigh then Exit; + if AIndex < crLow then Exit; + + // not yet loaded + Result := WidgetSet.CreateStandardCursor(AIndex); + if Result = 0 + then Result := LoadCursorFromLazarusResource('cur_' + IntToStr(-AIndex)); + if Result = 0 then Exit; + + FCursorMap.Add(AIndex, Result); end; {------------------------------------------------------------------------------ @@ -480,9 +468,10 @@ end; ------------------------------------------------------------------------------} procedure TScreen.SetCursor(const AValue: TCursor); begin - if AValue <> Cursor then begin + if AValue <> Cursor then + begin FCursor := AValue; - LCLIntf.SetCursor(Cursors[FCursor]); + WidgetSet.SetCursor(Cursors[FCursor]); end; Inc(FCursorCount); end; @@ -490,9 +479,22 @@ end; {------------------------------------------------------------------------------ procedure TScreen.SetCursors(Index: Integer; const AValue: HCURSOR); ------------------------------------------------------------------------------} -procedure TScreen.SetCursors(Index: Integer; const AValue: HCURSOR); +procedure TScreen.SetCursors(AIndex: Integer; const AValue: HCURSOR); begin - + case AIndex of + crDefault: begin + if (AValue = 0) and (WidgetSet <> nil) then + FDefaultCursor := WidgetSet.CreateStandardCursor(crDefault) + else + FDefaultCursor := AValue + end; + crNone: begin + end; + else + DeleteCursor(AIndex); + if AValue <> 0 then + FCursorMap.Add(AIndex, AValue); + end; end; {------------------------------------------------------------------------------ diff --git a/lcl/include/winapi.inc b/lcl/include/winapi.inc index 831d4df992..46e384b62b 100644 --- a/lcl/include/winapi.inc +++ b/lcl/include/winapi.inc @@ -115,6 +115,11 @@ begin Result := WidgetSet.CreateCompatibleDC(DC); end; +function CreateCursor(ACursorInfo: PIconInfo): hCursor; +begin + Result := WidgetSet.CreateCursor(ACursorInfo); +end; + function CreateFontIndirect(const LogFont: TLogFont): HFONT; begin Result := WidgetSet.CreateFontIndirect(LogFont); @@ -166,6 +171,11 @@ Begin Result := WidgetSet.DestroyCaret(Handle); end; +function DestroyCursor(Handle: hCursor): Boolean; +begin + Result := WidgetSet.DestroyCursor(Handle); +end; + Function DrawFrameControl(DC: HDC; var Rect : TRect; uType, uState : Cardinal) : Boolean; Begin Result := WidgetSet.DrawFrameControl(DC, Rect, uType, uState); diff --git a/lcl/include/winapih.inc b/lcl/include/winapih.inc index 66de0dc0f1..024b8aab09 100644 --- a/lcl/include/winapih.inc +++ b/lcl/include/winapih.inc @@ -54,6 +54,7 @@ function CreateBrushIndirect(const LogBrush: TLogBrush): HBRUSH; {$IFDEF IF_BASE function CreateCaret(Handle: HWND; Bitmap: hBitmap; width, Height: Integer): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function CreateCompatibleDC(DC: HDC): HDC; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} +function CreateCursor(ACursorInfo: PIconInfo): hCursor; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function CreateDIBitmap(DC: HDC; var InfoHeader: TBitmapInfoHeader; dwUsage: DWORD; InitBits: PChar; var InitInfo: TBitmapInfo; wUsage: UINT): HBITMAP; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} @@ -75,6 +76,8 @@ procedure DeleteCriticalSection(var CritSection: TCriticalSection); {$IFDEF IF_B function DeleteDC(hDC: HDC): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function DeleteObject(GDIObject: HGDIOBJ): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function DestroyCaret(Handle : HWND): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} +function DestroyCursor(Handle: hCursor): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} + function DPtoLP(DC: HDC; var Points; Count: Integer): BOOL; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function DrawFrameControl(DC: HDC; var Rect : TRect; uType, uState : Cardinal) : Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function DrawFocusRect(DC: HDC; const Rect: TRect): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} diff --git a/lcl/interfaces/gtk/gtkglobals.pp b/lcl/interfaces/gtk/gtkglobals.pp index 84a10f0b5d..6985b10c00 100644 --- a/lcl/interfaces/gtk/gtkglobals.pp +++ b/lcl/interfaces/gtk/gtkglobals.pp @@ -25,7 +25,8 @@ uses {$ELSE} glib, gdk, gtk, {$ENDIF} - LMessages, LCLProc, Controls, Forms, LCLIntf, LCLType, GTKDef, DynHashArray; + LMessages, LCLProc, Controls, Forms, LCLIntf, LCLType, GTKDef, DynHashArray, + Maps; {$I dragicons.inc} @@ -84,9 +85,8 @@ var // mouse cursors var - GDKMouseCursors: array[crLow..crHigh] of pGDKCursor; - // mapping from TCursor to gdk cursor index - CursorToGDKCursor: array[crLow..crHigh] of integer; + // Map a TCursor (<= 0 = HCursor) or a HCursor to a PGDKCursor + MMouseCursorMap: TMap; var LastFileSelectRow : gint; diff --git a/lcl/interfaces/gtk/gtkint.pp b/lcl/interfaces/gtk/gtkint.pp index d09d871c63..1fc1cfd559 100644 --- a/lcl/interfaces/gtk/gtkint.pp +++ b/lcl/interfaces/gtk/gtkint.pp @@ -103,7 +103,7 @@ uses // LCL ExtDlgs, Dialogs, Controls, Forms, LCLStrConsts, LMessages, LCLProc, LCLIntf, LCLType, GtkFontCache, gtkDef, GtkProc, DynHashArray, - gtkMsgQueue, GraphType, GraphMath, Graphics, Menus; + gtkMsgQueue, GraphType, GraphMath, Graphics, Menus, Maps; type @@ -428,42 +428,8 @@ begin end; // mouse cursors - for cr:=Low(GDKMouseCursors) to High(GDKMouseCursors) do begin - GDKMouseCursors[cr]:=nil; - CursorToGDKCursor[cr]:=GDK_LEFT_PTR; - end; - CursorToGDKCursor[crDefault] := GDK_LEFT_PTR; - CursorToGDKCursor[crNone] := GDK_LEFT_PTR; - CursorToGDKCursor[crArrow] := GDK_Arrow; - CursorToGDKCursor[crCross] := GDK_Cross; - CursorToGDKCursor[crIBeam] := GDK_XTerm; - CursorToGDKCursor[crSize] := GDK_FLEUR; - CursorToGDKCursor[crSizeNESW] := GDK_BOTTOM_LEFT_CORNER; - CursorToGDKCursor[crSizeNS] := GDK_SB_V_DOUBLE_ARROW; - CursorToGDKCursor[crSizeNWSE] := GDK_TOP_LEFT_CORNER; - CursorToGDKCursor[crSizeWE] := GDK_SB_H_DOUBLE_ARROW; - CursorToGDKCursor[crSizeNW] := GDK_TOP_LEFT_CORNER; - CursorToGDKCursor[crSizeN] := GDK_TOP_SIDE; - CursorToGDKCursor[crSizeNE] := GDK_TOP_RIGHT_CORNER; - CursorToGDKCursor[crSizeW] := GDK_LEFT_SIDE; - CursorToGDKCursor[crSizeE] := GDK_RIGHT_SIDE; - CursorToGDKCursor[crSizeSW] := GDK_BOTTOM_LEFT_CORNER; - CursorToGDKCursor[crSizeS] := GDK_BOTTOM_SIDE; - CursorToGDKCursor[crSizeSE] := GDK_BOTTOM_RIGHT_CORNER; - CursorToGDKCursor[crUpArrow] := GDK_LEFT_PTR; - CursorToGDKCursor[crHourGlass]:= GDK_CLOCK; - CursorToGDKCursor[crDrag] := GDK_SAILBOAT; - CursorToGDKCursor[crNoDrop] := GDK_IRON_CROSS; - CursorToGDKCursor[crHSplit] := GDK_SB_H_DOUBLE_ARROW; - CursorToGDKCursor[crVSplit] := GDK_SB_V_DOUBLE_ARROW; - CursorToGDKCursor[crMultiDrag]:= GDK_SAILBOAT; - CursorToGDKCursor[crSQLWait] := GDK_LEFT_PTR; - CursorToGDKCursor[crNo] := GDK_LEFT_PTR; - CursorToGDKCursor[crAppStart] := GDK_LEFT_PTR; - CursorToGDKCursor[crHelp] := GDK_QUESTION_ARROW; - CursorToGDKCursor[crHandPoint]:= GDK_Hand1; - CursorToGDKCursor[crSizeAll] := GDK_FLEUR; - + MMouseCursorMap := TMap.Create(its2, SizeOf(PGDKCursor)); + // charset encodings CharSetEncodingList := TList.Create; CreateDefaultCharsetEncodings; @@ -493,6 +459,8 @@ begin CharSetEncodingList.Free; CharSetEncodingList:=nil; end; + + FreeAndNil(MMouseCursorMap); end; diff --git a/lcl/interfaces/gtk/gtklclintfh.inc b/lcl/interfaces/gtk/gtklclintfh.inc index 351c4a3a60..c49fda4ffa 100644 --- a/lcl/interfaces/gtk/gtklclintfh.inc +++ b/lcl/interfaces/gtk/gtklclintfh.inc @@ -36,6 +36,8 @@ function AddPipeEventHandler(AHandle: THandle; function AddProcessEventHandler(AHandle: THandle; AEventHandler: TChildExitEvent; AData: PtrInt): PProcessEventHandler; override; +function CreateStandardCursor(ACursor: SmallInt): hCursor; override; + function DrawSplitter(DC: HDC; const ARect: TRect; Horizontal: boolean): boolean; override; function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; diff --git a/lcl/interfaces/gtk/gtkobject.inc b/lcl/interfaces/gtk/gtkobject.inc index 1308d6634a..c4db933883 100644 --- a/lcl/interfaces/gtk/gtkobject.inc +++ b/lcl/interfaces/gtk/gtkobject.inc @@ -5237,6 +5237,11 @@ begin gtk_widget_show(Result); end; +function TGTKWidgetSet.CreateStandardCursor(ACursor: SmallInt): hCursor; +begin + Result := GetPredefinedCursor(ACursor); +end; + {------------------------------------------------------------------------------ function TGtkWidgetSet.CreateToolBar(ToolBarObject: TObject): PGtkWidget; diff --git a/lcl/interfaces/gtk/gtkproc.inc b/lcl/interfaces/gtk/gtkproc.inc index 752c37d6d2..ccb19ee425 100644 --- a/lcl/interfaces/gtk/gtkproc.inc +++ b/lcl/interfaces/gtk/gtkproc.inc @@ -4796,7 +4796,7 @@ end; Sets the cursor for a widget. ------------------------------------------------------------------------------} -procedure SetCursor(AWinControl : TWinControl; ACursor: TCursor); +procedure SetCursor(AWinControl : TWinControl; ACursor: HCursor); procedure DoSetCursor(AWindow: PGdkWindow; Cursor: pGDKCursor); begin @@ -4831,18 +4831,18 @@ begin AWidget:= PGtkWidget(AWinControl.Handle); - if csDesigning in AWinControl.ComponentState then begin - + if csDesigning in AWinControl.ComponentState + then begin AWindow:=GetControlWindow(AWidget); if AWindow = nil then exit; if ACursor = crDefault then - SetCursorRecursive(AWindow, GetGDKMouseCursor(crDefault)) + SetCursorRecursive(AWindow, GetGDKMouseCursor(GetPredefinedCursor(crDefault))) else begin NewCursor:= GetGDKMouseCursor(ACursor); if NewCursor <> nil then SetCursorRecursive(AWindow, NewCursor); end; - - end else begin + end + else begin FixWidget:= GetFixedWidget(AWidget); AWindow:= GetControlWindow(FixWidget); @@ -4853,6 +4853,84 @@ begin end; end; +function GetPredefinedCursor(ACursor: TCursor): HCursor; +begin + Result := 0; + if ACursor > crHigh then Exit; + if ACursor < crLow then Exit; + + Result := ACursor - PREDEFINED_CURSOR_OFFSET; +end; + +function GetGDKMouseCursor(ACursor: HCursor): PGdkCursor; +var + CursorValue: Integer; +begin + Result := nil; + if ACursor < Low(SmallInt) then Exit; + if ACursor > High(SmallInt) then Exit; + + if MMouseCursorMap.GetData(ACursor, Result) then Exit; + // not yet created or illegal value + + if TCursor(ACursor + PREDEFINED_CURSOR_OFFSET) > crHigh then Exit; + if TCursor(ACursor + PREDEFINED_CURSOR_OFFSET) < crLow then Exit; + + // add it now + case TCursor(ACursor + PREDEFINED_CURSOR_OFFSET) of + crDefault: CursorValue := GDK_LEFT_PTR; + crNone: CursorValue := GDK_LEFT_PTR; + crArrow: CursorValue := GDK_Arrow; + crCross: CursorValue := GDK_Cross; + crIBeam: CursorValue := GDK_XTerm; +// crSize: CursorValue := GDK_FLEUR; + crSizeNESW: CursorValue := GDK_BOTTOM_LEFT_CORNER; + crSizeNS: CursorValue := GDK_SB_V_DOUBLE_ARROW; + crSizeNWSE: CursorValue := GDK_TOP_LEFT_CORNER; + crSizeWE: CursorValue := GDK_SB_H_DOUBLE_ARROW; + crSizeNW: CursorValue := GDK_TOP_LEFT_CORNER; + crSizeN: CursorValue := GDK_TOP_SIDE; + crSizeNE: CursorValue := GDK_TOP_RIGHT_CORNER; + crSizeW: CursorValue := GDK_LEFT_SIDE; + crSizeE: CursorValue := GDK_RIGHT_SIDE; + crSizeSW: CursorValue := GDK_BOTTOM_LEFT_CORNER; + crSizeS: CursorValue := GDK_BOTTOM_SIDE; + crSizeSE: CursorValue := GDK_BOTTOM_RIGHT_CORNER; + crUpArrow: CursorValue := GDK_LEFT_PTR; + crHourGlass:CursorValue := GDK_CLOCK; + crDrag: CursorValue := GDK_SAILBOAT; + crNoDrop: CursorValue := GDK_IRON_CROSS; + crHSplit: CursorValue := GDK_SB_H_DOUBLE_ARROW; + crVSplit: CursorValue := GDK_SB_V_DOUBLE_ARROW; + crMultiDrag:CursorValue := GDK_SAILBOAT; + crSQLWait: CursorValue := GDK_LEFT_PTR; + crNo: CursorValue := GDK_LEFT_PTR; + crAppStart: CursorValue := GDK_LEFT_PTR; + crHelp: CursorValue := GDK_QUESTION_ARROW; + crHandPoint:CursorValue := GDK_Hand1; + crSizeAll: CursorValue := GDK_FLEUR; + else + CursorValue := GDK_LEFT_PTR; + end; + + Result := gdk_cursor_new(CursorValue); + MMouseCursorMap.Add(ACursor, Result); +end; + +procedure FreeGDKCursors; +var + Iterator: TMapIterator; +begin + Iterator := TMapIterator.Create(MMouseCursorMap); + while not Iterator.EOM do + begin + gdk_Cursor_destroy(PGdkCursor(Iterator.DataPtr^)); + Iterator.Next; + end; + Iterator.Free; + MMouseCursorMap.Clear; +end; + {------------------------------------------------------------------------------- procedure: SignalConnect Params: AWidget: PGTKWidget @@ -8574,27 +8652,6 @@ begin //DebugLn('GetWindowFunction ',DbgSName(AForm),' ',dbgs(ord(ABorderStyle)),' ',binStr(Result,8)); end; -function GetGDKMouseCursor(Cursor: TCursor): PGdkCursor; -begin - if (CursorcrHigh) then - Cursor:=crDefault; - if GDKMouseCursors[Cursor]=nil then - GDKMouseCursors[Cursor]:=gdk_cursor_new(CursorToGDKCursor[Cursor]); - Result:=GDKMouseCursors[Cursor]; -end; - -Procedure FreeGDKCursors; -var - i: integer; -begin - for i:=Low(GDKMouseCursors) to High(GDKMouseCursors) do begin - if GDKMouseCursors[i]<>nil then begin - gdk_Cursor_Destroy(GDKMouseCursors[i]); - GDKMouseCursors[i]:=nil; - end; - end; -end; - Procedure FillScreenFonts(ScreenFonts : TStrings); var {$IFDEF GTK1} diff --git a/lcl/interfaces/gtk/gtkproc.pp b/lcl/interfaces/gtk/gtkproc.pp index be57b90f77..18caa20d3d 100644 --- a/lcl/interfaces/gtk/gtkproc.pp +++ b/lcl/interfaces/gtk/gtkproc.pp @@ -552,7 +552,6 @@ function GetWidgetOrigin(TheWidget: PGtkWidget): TPoint; function GetWidgetClientOrigin(TheWidget: PGtkWidget): TPoint; function TranslateGdkPointToClientArea(SourceWindow: PGdkWindow; SourcePos: TPoint; DestinationWidget: PGtkWidget): TPoint; -procedure SetCursor(AWinControl: TWinControl; ACursor: TCursor); // mouse capturing procedure CaptureMouseForWidget(Widget: PGtkWidget; Owner: TMouseCaptureType); @@ -562,8 +561,19 @@ procedure ReleaseCaptureWidget(Widget : PGtkWidget); procedure UpdateMouseCaptureControl; // mouse cursor -function GetGDKMouseCursor(Cursor: TCursor): PGdkCursor; -Procedure FreeGDKCursors; +procedure SetCursor(AWinControl: TWinControl; ACursor: HCursor); +function GetPredefinedCursor(ACursor: TCursor): HCursor; +function GetGDKMouseCursor(ACursor: hCursor): PGdkCursor; +procedure FreeGDKCursors; + +const + // for now return the same value, in the future we may want to return an + // offset of -1 so we can use 0 as error (now crDefault = 0) + // In the current situation, a TCursor is passed as hCursor. Since both are + // ordinals, the compiler won't complain + PREDEFINED_CURSOR_OFFSET = 0; //-1; + + // designing type diff --git a/lcl/interfaces/gtk/gtkwscontrols.pp b/lcl/interfaces/gtk/gtkwscontrols.pp index 7ee9665470..8373c0b90a 100644 --- a/lcl/interfaces/gtk/gtkwscontrols.pp +++ b/lcl/interfaces/gtk/gtkwscontrols.pp @@ -88,7 +88,7 @@ type class procedure SetBounds(const AWinControl: TWinControl; const ALeft, ATop, AWidth, AHeight: Integer); override; class procedure SetChildZPosition(const AWinControl, AChild: TWinControl; const AOldPos, ANewPos: Integer; const AChildren: TFPList); override; class procedure SetColor(const AWinControl: TWinControl); override; - class procedure SetCursor(const AControl: TControl; const ACursor: TCursor); override; + class procedure SetCursor(const AControl: TControl; const ACursor: HCursor); override; class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override; class procedure SetSize(const AWinControl: TWinControl; const AWidth, AHeight: Integer); override; class procedure SetPos(const AWinControl: TWinControl; const ALeft, ATop: Integer); override; @@ -384,8 +384,7 @@ begin end; end; -class procedure TGtkWSWinControl.SetCursor(const AControl: TControl; - const ACursor: TCursor); +class procedure TGtkWSWinControl.SetCursor(const AControl: TControl; const ACursor: HCursor); begin GtkProc.SetCursor(AControl as TWinControl, ACursor); end; diff --git a/lcl/interfaces/win32/win32callback.inc b/lcl/interfaces/win32/win32callback.inc index d145f62d2f..d569dda946 100644 --- a/lcl/interfaces/win32/win32callback.inc +++ b/lcl/interfaces/win32/win32callback.inc @@ -691,7 +691,7 @@ Var lControl := lWinControl; if lControl.Cursor <> crDefault then begin - Windows.SetCursor(Windows.LoadCursor(0, LclCursorToWin32CursorMap[lControl.Cursor])); + Windows.SetCursor(Screen.Cursors[lControl.Cursor]); LMessage.Result := 1; end; end; diff --git a/lcl/interfaces/win32/win32lclintf.inc b/lcl/interfaces/win32/win32lclintf.inc index fbb447dae6..0d63093754 100644 --- a/lcl/interfaces/win32/win32lclintf.inc +++ b/lcl/interfaces/win32/win32lclintf.inc @@ -147,6 +147,36 @@ begin AHandler := nil; end; +{------------------------------------------------------------------------------ + Function: + Params: + + Returns: + + ------------------------------------------------------------------------------} +function TWin32WidgetSet.CreateStandardCursor(ACursor: SmallInt): hCursor; +begin + Result := 0; + if ACursor < crLow then Exit; + if ACursor > crHigh then Exit; + + case ACursor of + crSqlWait..crDrag, + crHandPoint: begin + // TODO: load custom cursors here not in the LCL + end; + else + Result := Windows.LoadCursor(0, LclCursorToWin32CursorMap[ACursor]); + end; +end; + +{------------------------------------------------------------------------------ + Procedure: + Params: + + Returns: + + ------------------------------------------------------------------------------} procedure TWin32WidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent); const { up, down, left, right } diff --git a/lcl/interfaces/win32/win32lclintfh.inc b/lcl/interfaces/win32/win32lclintfh.inc index 9aaec970e1..958def6908 100644 --- a/lcl/interfaces/win32/win32lclintfh.inc +++ b/lcl/interfaces/win32/win32lclintfh.inc @@ -35,7 +35,9 @@ function AddPipeEventHandler(AHandle: THandle; AEventHandler: TPipeEvent; AData: PtrInt): PPipeEventHandler; override; function AddProcessEventHandler(AHandle: THandle; AEventHandler: TChildExitEvent; AData: PtrInt): PProcessEventHandler; override; - + +function CreateStandardCursor(ACursor: SmallInt): hCursor; override; + procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override; function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override; diff --git a/lcl/interfaces/win32/win32object.inc b/lcl/interfaces/win32/win32object.inc index 00beae79ca..48ec0376b3 100644 --- a/lcl/interfaces/win32/win32object.inc +++ b/lcl/interfaces/win32/win32object.inc @@ -538,7 +538,7 @@ Begin hIcon := Windows.LoadIcon(MainInstance, 'MAINICON'); if hIcon = 0 then hIcon := Windows.LoadIcon(0, IDI_APPLICATION); - hCursor := LoadCursor(0, IDC_ARROW); + hCursor := Windows.LoadCursor(0, IDC_ARROW); hbrBackground := 0; {GetSysColorBrush(Color_BtnFace);} LPSzMenuName := Nil; LPSzClassName := PWideChar(WideString(ClsName)); @@ -556,7 +556,7 @@ Begin hIcon := Windows.LoadIcon(MainInstance, 'MAINICON'); if hIcon = 0 then hIcon := Windows.LoadIcon(0, IDI_APPLICATION); - hCursor := LoadCursor(0, IDC_ARROW); + hCursor := Windows.LoadCursor(0, IDC_ARROW); hbrBackground := 0; {GetSysColorBrush(Color_BtnFace);} LPSzMenuName := Nil; LPSzClassName := @ClsName; diff --git a/lcl/interfaces/win32/win32winapi.inc b/lcl/interfaces/win32/win32winapi.inc index ed20fa11c8..46a93364ec 100644 --- a/lcl/interfaces/win32/win32winapi.inc +++ b/lcl/interfaces/win32/win32winapi.inc @@ -722,6 +722,18 @@ Begin Assert(False, Format('Trace:[TWin32WidgetSet.CreateCompatibleDC] DC: 0x%x --> 0x%x', [Integer(DC), Integer(Result)])); End; +{------------------------------------------------------------------------------ + Method: CreateCursor + Params: AInstance - handle to instance; ACursorInfo - pointer to Cursor Information record + Returns: handle to a created cursor + + Creates a cursor by color and mask bitmaps and other indo. + ------------------------------------------------------------------------------} +Function TWin32WidgetSet.CreateCursor(ACursorInfo: PIconInfo): hCursor; +begin + Result := Windows.CreateIconIndirect(ACursorInfo); +end; + {------------------------------------------------------------------------------ Method: CreateFontIndirect Params: LogFont - logical font record @@ -1058,6 +1070,18 @@ Begin Result := Boolean(Windows.DestroyCaret); End; +{------------------------------------------------------------------------------ + Method: DestroyCursor + Params: Handle - handle to the cursor object + Returns: If the function succeeds + + Destroys the cursor + ------------------------------------------------------------------------------} +Function TWin32WidgetSet.DestroyCursor(Handle: hCursor): Boolean; +Begin + Result := Boolean(Windows.DestroyCursor(Handle)); +End; + {------------------------------------------------------------------------------ Method: DrawFrameControl Params: DC - handle to device context @@ -2978,7 +3002,7 @@ End; function TWin32WidgetSet.SetCursor(hCursor: HICON): HCURSOR; begin - Result := Windows.SetCursor(Windows.LoadCursor(0, LclCursorToWin32CursorMap[hCursor])); + Result := Windows.SetCursor(hCursor); end; {------------------------------------------------------------------------------ diff --git a/lcl/interfaces/win32/win32winapih.inc b/lcl/interfaces/win32/win32winapih.inc index 1707a6c2a5..9785ed85f3 100644 --- a/lcl/interfaces/win32/win32winapih.inc +++ b/lcl/interfaces/win32/win32winapih.inc @@ -51,6 +51,7 @@ function CreateBrushIndirect(Const LogBrush: TLogBrush): HBRUSH; Override; function CreateCaret(Handle: HWND; Bitmap: HBITMAP; Width, Height: Integer): Boolean; Override; function CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP; Override; function CreateCompatibleDC(DC: HDC): HDC; Override; +function CreateCursor(ACursorInfo: PIconInfo): hCursor; Override; function CreateDIBSection(DC: HDC; const p2: tagBitmapInfo; p3: UINT; var p4: Pointer; p5: THandle; p6: DWORD): HBITMAP; Override; function CreateFontIndirect(Const LogFont: TLogFont): HFONT; Override; @@ -63,6 +64,7 @@ function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN; Override; function DeleteDC(HDC: HDC): Boolean; Override; function DeleteObject(GDIObject: HGDIOBJ): Boolean; Override; function DestroyCaret(Handle: HWND): Boolean; Override; +function DestroyCursor(Handle: hCursor): Boolean; Override; function DrawFrameControl(DC: HDC; Var Rect: TRect; UType, UState: Cardinal): Boolean; Override; function DrawFocusRect(DC: HDC; const Rect: TRect): boolean; override; function DrawEdge(DC: HDC; Var Rect: TRect; Edge: Cardinal; GrfFlags: Cardinal): Boolean; Override; diff --git a/lcl/interfaces/win32/win32wscontrols.pp b/lcl/interfaces/win32/win32wscontrols.pp index 85047af938..1d3f48a370 100644 --- a/lcl/interfaces/win32/win32wscontrols.pp +++ b/lcl/interfaces/win32/win32wscontrols.pp @@ -56,7 +56,7 @@ type private protected public - class procedure SetCursor(const AControl: TControl; const ACursor: TCursor); override; + class procedure SetCursor(const AControl: TControl; const ACursor: HCursor); override; end; { TWin32WSWinControl } @@ -275,9 +275,10 @@ end; { TWin32WSControl } -class procedure TWin32WSControl.SetCursor(const AControl: TControl; const ACursor: TCursor); +class procedure TWin32WSControl.SetCursor(const AControl: TControl; const ACursor: HCursor); begin - Windows.SetCursor(Windows.LoadCursor(0, LclCursorToWin32CursorMap[ACursor])); + Windows.SetCursor(ACursor); + //Windows.SetCursor(Windows.LoadCursor(0, LclCursorToWin32CursorMap[ACursor])); end; { TWin32WSWinControl } diff --git a/lcl/intfgraphics.pas b/lcl/intfgraphics.pas index d6d3770497..39c17485d6 100644 --- a/lcl/intfgraphics.pas +++ b/lcl/intfgraphics.pas @@ -3564,6 +3564,7 @@ end; procedure TLazReaderPartIcon.InternalRead(Stream: TStream; Img: TFPCustomImage); var Row, Column: Integer; + NewColor: TFPColor; begin InternalReadHead(Stream, Img); @@ -3572,15 +3573,54 @@ begin { Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header } // MWE: is the height then stil devided by 2 ? - if BFI.biBitCount < 32 then begin + if BFI.biBitCount < 32 then + begin ReadSize:=((Img.Width + 31) div 32) shl 2; SetupRead(2,Img.Width,Stream,False); try - for Row:=Img.Height-1 downto 0 do begin + for Row:=Img.Height-1 downto 0 do + begin ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize. + { + ---------------- delete this comment, or apply ------------------------ + Paul Ishenin: My suggestion is to skip this color setting at all + and replace it with direct writing of LineBuf into FMaskData. This will + significantly speed up mask setting. + + e.g. I test this code and it works fine: + + if (Img is TLazIntfImage) and (TLazIntfImage(Img).FMaskData <> nil) then + for i := 0 to ReadSize - 1 do + TLazIntfImage(Img).FMaskData[(Row * ReadSize) + i] := LineBuf[i]; + + ---------------- now it works so: -------------------------------------- + For cursors: we should not change main bitmap colors, but we should + set mask. If we get 1 in LineBuf bit, then we need set 1 into Mask. + If alpha part of color is alphaOpaque ($FFFF) then we set 1 into Mask + else if alpha is alphaTransparent ($0000) then we set 0 into Mask + so it is just "bit by bit copying" from LineBuf into FMaskData + if we need speed up this copying then read my comment before + } + for Column:=0 to Img.Width-1 do if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then - img.colors[Column,Row]:=colTransparent + begin + // I dont want change something in Icon loading code, so I add conditions + // ClassType = TLazReaderCursor when need + if ClassType = TLazReaderCursor then + begin + NewColor := img.colors[Column,Row]; + NewColor.alpha := alphaOpaque; + end else + NewColor := colTransparent; + img.colors[Column,Row] := NewColor; + end else + if ClassType = TLazReaderCursor then + begin + NewColor := img.colors[Column,Row]; + NewColor.alpha := alphaTransparent; + img.colors[Column,Row] := NewColor; + end; end; finally FreeBufs; @@ -3609,21 +3649,21 @@ type idType: Word; {1 - Icon, 2 - Cursor} idCount: Word; {number of icons in file} end; - + TIconDirEntry = packed record bWidth: Byte; {ie: 16 or 32} bHeight: Byte; {ie: 16 or 32} bColorCount: Byte; {number of entires in pallette table below} bReserved: Byte; { not used = 0} - wPlanes: Word; { not used = 0} - wBitCount: Word; { not used = 0} + wXHotSpot: Word; { used for Cursor otherwise = 0} + wYHotSpot: Word; { used for Cursor otherwise = 0} dwBytesInRes: Longint; {total number bytes in images including pallette data XOR, AND and bitmap info header} dwImageOffset: Longint; {pos of image as offset from the beginning of file} end; - - PIconDirEntry = ^TIconDirEntry; + PIconDirEntry = ^TIconDirEntry; + procedure TLazReaderIcon.SetIcon(const AValue: TObject); begin if AValue is TIcon then @@ -3655,13 +3695,18 @@ begin BestDirEntry := CurrentDirEntry; Inc(CurrentDirEntry); end; - if Assigned(Icon) then begin + if Assigned(Icon) then + begin CurrentDirEntry := IconDir; - for i := 1 to FnIcons do begin + if Icon is TCursorImage then + TCursorImage(Icon).HotSpot := Point(IconDir^.wXHotSpot, IconDir^.wYHotSpot); + for i := 1 to FnIcons do + begin Stream.Position := FnStartPos + CurrentDirEntry^.dwImageOffset; if CurrentDirEntry = BestDirEntry then inherited InternalRead(Stream, Img) - else begin + else + begin Bitmap := TBitmap.Create; try Bitmap.ReadStreamWithFPImage(Stream, False, 0, TLazReaderPartIcon); @@ -3673,7 +3718,8 @@ begin end; Inc(CurrentDirEntry); end; - end else begin + end else + begin Stream.Position := FnStartPos + BestDirEntry^.dwImageOffset; inherited InternalRead(Stream, Img); { Finally skip remaining icons } diff --git a/lcl/lcltype.pp b/lcl/lcltype.pp index 3e09eabc14..1d74443314 100644 --- a/lcl/lcltype.pp +++ b/lcl/lcltype.pp @@ -2054,6 +2054,22 @@ type WindowClass: TWndClass; WinClassName: array[0..63] of Char; end; + +type +{$ifdef windows} + TIconInfo = Windows.TICONINFO; + PIconInfo = Windows.PICONINFO; +{$else windows} + TIconInfo = record + fIcon: BOOL; + xHotspot: DWORD; + yHotspot: DWORD; + hbmMask: HBITMAP; + hbmColor: HBITMAP; + end; + PIconInfo = ^TIconInfo; +{$endif windows} + //------------------------------------------------------------------------------ // prototype for timer callback diff --git a/lcl/widgetset/wscontrols.pp b/lcl/widgetset/wscontrols.pp index 9b02fb2aeb..fa8a7537f7 100644 --- a/lcl/widgetset/wscontrols.pp +++ b/lcl/widgetset/wscontrols.pp @@ -61,7 +61,7 @@ type TWSControl = class(TWSLCLComponent) class procedure AddControl(const AControl: TControl); virtual; - class procedure SetCursor(const AControl: TControl; const ACursor: TCursor); virtual; + class procedure SetCursor(const AControl: TControl; const ACursor: HCursor); virtual; end; TWSControlClass = class of TWSControl; @@ -125,7 +125,7 @@ class procedure TWSControl.AddControl(const AControl: TControl); begin end; -class procedure TWSControl.SetCursor(const AControl: TControl; const ACursor: TCursor); +class procedure TWSControl.SetCursor(const AControl: TControl; const ACursor: HCursor); begin end;