View Issue Details

IDProjectCategoryView StatusLast Update
0038284Lazarus CCRPackagespublic2020-12-31 19:10
Reporterregs Assigned Towp  
PrioritynormalSeverityminorReproducibilityhave not tried
Status resolvedResolutionfixed 
Summary0038284: Zoom to cursor for LazMapViewer
DescriptionKeeping location under cursor while zooming in and out. Similar to many online maps.
Tagslazmapviewer
Widgetset
Attached Files

Activities

regs

2020-12-31 02:04

reporter  

zoomtocursor.diff (5,693 bytes)   
Index: mvengine.pas
===================================================================
--- mvengine.pas	(revision 7951)
+++ mvengine.pas	(working copy)
@@ -47,6 +47,8 @@
     Zoom: integer;
     Height: integer;
     Width: integer;
+    ZoomCenter: TRealPoint;
+    ZoomOffset: TPoint;
   end;
 
 
@@ -66,6 +68,7 @@
       lstProvider : TStringList;
       Queue : TJobQueue;
       MapWin : TMapWindow;
+      FZoomToCursor: Boolean;
       function GetCacheOnDisk: Boolean;
       function GetCachePath: String;
       function GetCenter: TRealPoint;
@@ -85,7 +88,8 @@
       procedure SetMapProvider(AValue: String);
       procedure SetUseThreads(AValue: Boolean);
       procedure SetWidth(AValue: integer);
-      procedure SetZoom(AValue: integer);
+      procedure SetZoom(AValue: integer); overload;
+      procedure SetZoom(AValue: integer; AZoomToCursor: Boolean = False); overload;
       function DegreesToMapPixels(const AWin: TMapWindow; ALonLat: TRealPoint): TPoint;
       function MapPixelsToDegrees(const AWin: TMapWindow; APoint: TPoint): TRealPoint;
       function PixelsToDegreesEPSG3395(APoint: TPoint; Zoom: Integer): TRealPoint;
@@ -93,6 +97,7 @@
       procedure CalculateWin(var AWin: TMapWindow);
       function DegreesToPixelsEPSG3395(const AWin: TMapWindow; ALonLat: TRealPoint): TPoint;
       function DegreesToPixelsEPSG3857(const AWin: TMapWindow; ALonLat: TRealPoint): TPoint;
+      procedure AdjustZoomCenter(var aWin: TMapWindow);
       procedure Redraw(const aWin: TMapWindow);
       function CalculateVisibleTiles(const aWin: TMapWindow) : TArea;
       function IsCurrentWin(const aWin: TMapWindow) : boolean;
@@ -151,6 +156,7 @@
       property UseThreads: Boolean read GetUseThreads write SetUseThreads;
       property Width: integer read GetWidth write SetWidth;
       property Zoom: integer read GetZoom write SetZoom;
+      property ZoomToCursor: Boolean read FZoomToCursor write FZoomToCursor default True;
 
       property OnCenterMove: TNotifyEvent read FOnCenterMove write FOnCenterMove;
       property OnChange: TNotifyEvent Read FOnChange write FOnchange; //called when visiable area change
@@ -373,6 +379,20 @@
   Result.AddUrl(Url, ProjectionType, NbSvr, MinZoom, MaxZoom, GetSvrStr, GetXStr, GetYStr, GetZStr);
 end;
 
+procedure TMapViewerEngine.AdjustZoomCenter(var aWin: TMapWindow);
+var
+  ptMouseCursor: TPoint;
+  rPtAdjustedCenter: TRealPoint;
+begin
+
+  ptMouseCursor := LonLatToScreen(aWin.ZoomCenter);
+  rPtAdjustedCenter := ScreenToLonLat(ptMouseCursor.Add(aWin.ZoomOffset));
+  aWin.Center := rPtAdjustedCenter;
+
+  CalculateWin(aWin);
+
+end;
+
 function TMapViewerEngine.CalculateVisibleTiles(const aWin: TMapWindow): TArea;
 var
   MaxX, MaxY, startX, startY: int64;
@@ -785,8 +805,13 @@
 var
   Val: Integer;
   nZoom: integer;
+  bZoomToCursor: Boolean;
+
 begin
+
+  bZoomToCursor := False;
   Val := 0;
+
   if WheelDelta > 0 then
     Val := 1;
   if WheelDelta < 0 then
@@ -793,8 +818,18 @@
     Val := -1;
   nZoom := Zoom + Val;
   if (nZoom > 0) and (nZoom < 20) then
-    Zoom := nZoom;
-  Handled := true;
+  begin
+    if ZoomToCursor then
+    begin
+      MapWin.ZoomCenter := ScreenToLonLat(MousePos);
+      MapWin.ZoomOffset := LonLatToScreen(Center).Subtract(MousePos);
+      bZoomToCursor := True;
+    end;
+    SetZoom(nZoom, bZoomToCursor);
+  end;
+
+  Handled := True;
+
 end;
 
 procedure TMapViewerEngine.MoveMapCenter(Sender: TDragObj);
@@ -1156,10 +1191,17 @@
 
 procedure TMapViewerEngine.SetZoom(AValue: integer);
 begin
+  SetZoom(AValue, False);
+end;
+
+procedure TMapViewerEngine.SetZoom(AValue: integer; AZoomToCursor: Boolean = False);
+begin
   if MapWin.Zoom = AValue then Exit;
   MapWin.Zoom := AValue;
   ConstraintZoom(MapWin);
   CalculateWin(MapWin);
+  if AZoomToCursor then
+    AdjustZoomCenter(MapWin);
   Redraw(MapWin);
   if Assigned(OnZoomChange) then
     OnZoomChange(Self);
Index: mvmapviewer.pas
===================================================================
--- mvmapviewer.pas	(revision 7951)
+++ mvmapviewer.pas	(working copy)
@@ -105,6 +105,8 @@
       procedure Paint; override;
       procedure OnGPSItemsModified(Sender: TObject; objs: TGPSObjList;
         Adding: boolean);
+      function GetZoomToCursor: Boolean;
+      procedure SetZoomToCursor(AValue: Boolean);
     public
       constructor Create(AOwner: TComponent); override;
       destructor Destroy; override;
@@ -143,6 +145,7 @@
       property UseThreads: boolean read GetUseThreads write SetUseThreads default false;
       property Width default 150;
       property Zoom: integer read GetZoom write SetZoom;
+      property ZoomToCursor: Boolean read GetZoomToCursor write SetZoomToCursor default True;
       property OnCenterMove: TNotifyEvent read GetOnCenterMove write SetOnCenterMove;
       property OnZoomChange: TNotifyEvent read GetOnZoomChange write SetOnZoomChange;
       property OnChange: TNotifyEvent read GetOnChange write SetOnChange;
@@ -740,6 +743,7 @@
   FEngine.OnDrawTile := @DoDrawTile;
   FEngine.DrawTitleInGuiThread := false;
   FEngine.DownloadEngine := FBuiltinDownloadEngine;
+  FEngine.ZoomToCursor := True;
 
   FBuiltinDrawingEngine := TMvIntfGraphicsDrawingEngine.Create(self);
   FBuiltinDrawingEngine.Name := 'BuiltInDE';
@@ -850,6 +854,16 @@
   Result.BottomRight := Engine.ScreenToLonLat(aPt);;
 end;
 
+function TMapView.GetZoomToCursor: Boolean;
+begin
+  Result := Engine.ZoomToCursor;
+end;
+
+procedure TMapView.SetZoomToCursor(AValue: Boolean);
+begin
+  Engine.ZoomToCursor := AValue;
+end;
+
 procedure TMapView.ClearBuffer;
 begin
   DrawingEngine.CreateBuffer(ClientWidth, ClientHeight);       // ???
zoomtocursor.diff (5,693 bytes)   
zoomtocursor_example.diff (5,392 bytes)   
Index: main.lfm
===================================================================
--- main.lfm	(revision 7951)
+++ main.lfm	(working copy)
@@ -10,7 +10,7 @@
   OnDestroy = FormDestroy
   OnShow = FormShow
   ShowHint = True
-  LCLVersion = '2.1.0.0'
+  LCLVersion = '2.0.6.0'
   object MapView: TMapView
     Left = 0
     Height = 640
@@ -27,6 +27,7 @@
     MapProvider = 'OpenStreetMap Mapnik'
     UseThreads = True
     Zoom = 0
+    ZoomToCursor = False
     OnZoomChange = MapViewZoomChange
     OnChange = MapViewChange
     OnMouseLeave = MapViewMouseLeave
@@ -38,9 +39,9 @@
     Height = 640
     Top = 0
     Width = 275
-    ActivePage = PgData
+    ActivePage = PgConfig
     Align = alRight
-    TabIndex = 0
+    TabIndex = 1
     TabOrder = 1
     object PgData: TTabSheet
       Caption = 'Data'
@@ -673,14 +674,14 @@
       end
       object CbUseThreads: TCheckBox
         AnchorSideLeft.Control = PgConfig
-        AnchorSideTop.Control = CbProviders
+        AnchorSideTop.Control = CbZoomToCursor
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 19
-        Top = 56
+        Top = 81
         Width = 81
         BorderSpacing.Left = 6
-        BorderSpacing.Top = 8
+        BorderSpacing.Top = 6
         Caption = 'Use threads'
         Checked = True
         OnChange = CbUseThreadsChange
@@ -693,7 +694,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 19
-        Top = 81
+        Top = 106
         Width = 87
         BorderSpacing.Top = 6
         BorderSpacing.Right = 9
@@ -709,7 +710,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 19
-        Top = 106
+        Top = 131
         Width = 79
         BorderSpacing.Top = 6
         Caption = 'Debug tiles'
@@ -721,7 +722,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 16
         Height = 25
-        Top = 230
+        Top = 255
         Width = 93
         AutoSize = True
         BorderSpacing.Top = 8
@@ -737,7 +738,7 @@
         AnchorSideRight.Side = asrBottom
         Left = 164
         Height = 22
-        Top = 231
+        Top = 256
         Width = 97
         NoneColorColor = clWhite
         Style = [cbStandardColors, cbExtendedColors, cbIncludeNone, cbCustomColor, cbPrettyNames, cbCustomColors]
@@ -754,7 +755,7 @@
         AnchorSideTop.Side = asrCenter
         Left = 117
         Height = 15
-        Top = 235
+        Top = 260
         Width = 39
         BorderSpacing.Left = 8
         Caption = 'Backgr.'
@@ -767,7 +768,7 @@
         AnchorSideRight.Side = asrBottom
         Left = 6
         Height = 4
-        Top = 133
+        Top = 158
         Width = 255
         Anchors = [akTop, akLeft, akRight]
         BorderSpacing.Top = 8
@@ -779,7 +780,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 77
-        Top = 145
+        Top = 170
         Width = 143
         AutoFill = True
         AutoSize = True
@@ -803,23 +804,39 @@
         OnClick = rgPOIModeClick
         TabOrder = 6
       end
+      object CbZoomToCursor: TCheckBox
+        AnchorSideLeft.Control = PgConfig
+        AnchorSideTop.Control = CbProviders
+        AnchorSideTop.Side = asrBottom
+        Left = 6
+        Height = 19
+        Top = 56
+        Width = 102
+        BorderSpacing.Left = 6
+        BorderSpacing.Top = 8
+        Caption = 'Zoom to cursor'
+        Checked = True
+        OnChange = CbZoomToCursorChange
+        State = cbChecked
+        TabOrder = 7
+      end
     end
   end
   object GeoNames: TMVGeoNames
     OnNameFound = GeoNamesNameFound
-    Left = 240
-    Top = 192
+    left = 240
+    top = 192
   end
   object OpenDialog: TOpenDialog
     DefaultExt = '.pgx'
     Filter = 'GPX files (*.gpx)|*.gpx|All files (*.*)|*.*'
-    Left = 240
-    Top = 456
+    left = 240
+    top = 456
   end
   object FontDialog: TFontDialog
     MinFontSize = 0
     MaxFontSize = 0
-    Left = 680
-    Top = 296
+    left = 808
+    top = 104
   end
 end
Index: main.pas
===================================================================
--- main.pas	(revision 7951)
+++ main.pas	(working copy)
@@ -30,6 +30,7 @@
     CbDistanceUnits: TComboBox;
     CbDebugTiles: TCheckBox;
     cbPOITextBgColor: TColorBox;
+    CbZoomToCursor: TCheckBox;
     FontDialog: TFontDialog;
     GbCenterCoords: TGroupBox;
     GbScreenSize: TGroupBox;
@@ -78,6 +79,7 @@
     procedure CbShowPOIImageChange(Sender: TObject);
     procedure CbUseThreadsChange(Sender: TObject);
     procedure CbDistanceUnitsChange(Sender: TObject);
+    procedure CbZoomToCursorChange(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure FormShow(Sender: TObject);
@@ -312,6 +314,11 @@
   UpdateViewPortSize;
 end;
 
+procedure TMainForm.CbZoomToCursorChange(Sender: TObject);
+begin
+  MapView.ZoomToCursor := CbZoomToCursor.Checked;
+end;
+
 procedure TMainForm.ClearFoundLocations;
 var
   i: Integer;
@@ -337,6 +344,7 @@
   CbProviders.ItemIndex := CbProviders.Items.Indexof(MapView.MapProvider);
   MapView.DoubleBuffered := true;
   MapView.Zoom := 1;
+  CbZoomToCursor.Checked := MapView.ZoomToCursor;
   CbUseThreads.Checked := MapView.UseThreads;
   CbDoubleBuffer.Checked := MapView.DoubleBuffered;
   CbPOITextBgColor.Selected := MapView.POITextBgColor;
zoomtocursor_example.diff (5,392 bytes)   
zoomtocursor_example_with_addons.diff (4,588 bytes)   
Index: main.lfm
===================================================================
--- main.lfm	(revision 7951)
+++ main.lfm	(working copy)
@@ -10,7 +10,6 @@
   OnDestroy = FormDestroy
   OnShow = FormShow
   ShowHint = True
-  LCLVersion = '2.1.0.0'
   object MapView: TMapView
     Left = 0
     Height = 640
@@ -710,14 +709,14 @@
       end
       object CbUseThreads: TCheckBox
         AnchorSideLeft.Control = PgConfig
-        AnchorSideTop.Control = CbProviders
+        AnchorSideTop.Control = CbZoomToCursor
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 19
-        Top = 102
+        Top = 127
         Width = 81
         BorderSpacing.Left = 6
-        BorderSpacing.Top = 8
+        BorderSpacing.Top = 6
         Caption = 'Use threads'
         Checked = True
         OnChange = CbUseThreadsChange
@@ -730,7 +729,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 19
-        Top = 127
+        Top = 152
         Width = 87
         BorderSpacing.Top = 6
         BorderSpacing.Right = 9
@@ -746,7 +745,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 19
-        Top = 152
+        Top = 177
         Width = 79
         BorderSpacing.Top = 6
         Caption = 'Debug tiles'
@@ -759,7 +758,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 19
-        Top = 189
+        Top = 214
         Width = 107
         BorderSpacing.Top = 6
         Caption = 'Show POI image'
@@ -771,7 +770,7 @@
         AnchorSideTop.Side = asrBottom
         Left = 6
         Height = 25
-        Top = 216
+        Top = 241
         Width = 93
         AutoSize = True
         BorderSpacing.Top = 8
@@ -788,7 +787,7 @@
         AnchorSideRight.Side = asrBottom
         Left = 154
         Height = 22
-        Top = 217
+        Top = 242
         Width = 107
         NoneColorColor = clWhite
         Style = [cbStandardColors, cbExtendedColors, cbIncludeNone, cbCustomColor, cbPrettyNames, cbCustomColors]
@@ -805,7 +804,7 @@
         AnchorSideTop.Side = asrCenter
         Left = 107
         Height = 15
-        Top = 221
+        Top = 246
         Width = 39
         BorderSpacing.Left = 8
         Caption = 'Backgr.'
@@ -819,12 +818,28 @@
         AnchorSideRight.Side = asrBottom
         Left = 6
         Height = 4
-        Top = 179
+        Top = 204
         Width = 255
         Anchors = [akTop, akLeft, akRight]
         BorderSpacing.Top = 8
         Shape = bsTopLine
       end
+      object CbZoomToCursor: TCheckBox
+        AnchorSideLeft.Control = PgConfig
+        AnchorSideTop.Control = CbProviders
+        AnchorSideTop.Side = asrBottom
+        Left = 6
+        Height = 19
+        Top = 102
+        Width = 102
+        BorderSpacing.Left = 6
+        BorderSpacing.Top = 8
+        Caption = 'Zoom to cursor'
+        Checked = True
+        OnChange = CbZoomToCursorChange
+        State = cbChecked
+        TabOrder = 8
+      end
     end
   end
   object GeoNames: TMVGeoNames
@@ -841,7 +856,7 @@
   object FontDialog: TFontDialog
     MinFontSize = 0
     MaxFontSize = 0
-    left = 648
-    top = 280
+    left = 816
+    top = 152
   end
 end
Index: main.pas
===================================================================
--- main.pas	(revision 7951)
+++ main.pas	(working copy)
@@ -33,6 +33,7 @@
     CbDrawingEngine: TComboBox;
     CbShowPOIImage: TCheckBox;
     cbPOITextBgColor: TColorBox;
+    CbZoomToCursor: TCheckBox;
     FontDialog: TFontDialog;
     GbCenterCoords: TGroupBox;
     GbScreenSize: TGroupBox;
@@ -82,6 +83,7 @@
     procedure CbShowPOIImageChange(Sender: TObject);
     procedure CbUseThreadsChange(Sender: TObject);
     procedure CbDistanceUnitsChange(Sender: TObject);
+    procedure CbZoomToCursorChange(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure FormShow(Sender: TObject);
@@ -332,6 +334,11 @@
   UpdateViewPortSize;
 end;
 
+procedure TMainForm.CbZoomToCursorChange(Sender: TObject);
+begin
+  MapView.ZoomToCursor := CbZoomToCursor.Checked;
+end;
+
 procedure TMainForm.ClearFoundLocations;
 var
   i: Integer;
@@ -357,6 +364,7 @@
   CbProviders.ItemIndex := CbProviders.Items.Indexof(MapView.MapProvider);
   MapView.DoubleBuffered := true;
   MapView.Zoom := 1;
+  CbZoomToCursor.Checked := MapView.ZoomToCursor;
   CbUseThreads.Checked := MapView.UseThreads;
   CbDoubleBuffer.Checked := MapView.DoubleBuffered;
   CbPOITextBgColor.Selected := MapView.POITextBgColor;

wp

2020-12-31 19:10

developer   ~0127979

Thanks for this nice feature. Patch applied with minor modifications. Please test and close if ok.

Issue History

Date Modified Username Field Change
2020-12-31 02:04 regs New Issue
2020-12-31 02:04 regs File Added: zoomtocursor.diff
2020-12-31 02:04 regs File Added: zoomtocursor_example.diff
2020-12-31 02:04 regs File Added: zoomtocursor_example_with_addons.diff
2020-12-31 02:04 regs Tag Attached: lazmapviewer
2020-12-31 11:56 wp Assigned To => wp
2020-12-31 11:56 wp Status new => assigned
2020-12-31 19:10 wp Status assigned => resolved
2020-12-31 19:10 wp Resolution open => fixed
2020-12-31 19:10 wp Note Added: 0127979