Changeset 212 for branches/highdpi/Packages/DpiControls/UDpiControls.pas

Timestamp:

May 9, 2020, 9:35:25 PM (4 years ago)

Author:

chronos

Message:

• Fixed: Better High DPI scaling on highdpi branch.

File:

• branches/highdpi/Packages/DpiControls/UDpiControls.pas (modified) (21 diffs)

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -38 +38 @@
     property OnMouseUp;
     property OnMouseMove;
+    property OnMouseWheel;
+    property OnMouseLeave;
+    property OnMouseEnter;
   end;
 
@@ -122 +125 @@
     FLeft: Integer;
     FOnChangeBounds: TNotifyEvent;
+    FOnMouseUp: TMouseEvent;
     FOnMouseDown: TMouseEvent;
     FOnMouseMove: TMouseMoveEvent;
-    FOnMouseUp: TMouseEvent;
+    FOnMouseEnter: TNotifyEvent;
+    FOnMouseLeave: TNotifyEvent;
     FOnMouseWheel: TMouseWheelEvent;
     FOnResize: TNotifyEvent;
@@ -161 +166 @@
     procedure DoFormResize;
     procedure DoChangeBounds;
+    procedure MouseDownHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
+      X, Y: Integer); virtual;
+    procedure MouseUpHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
+      X, Y: Integer); virtual;
+    procedure MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;
+    procedure MouseWheelHandler(Sender: TObject; Shift: TShiftState;
+         WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual;
+    procedure MouseLeaveHandler(Sender: TObject); virtual;
+    procedure MouseEnterHandler(Sender: TObject); virtual;
   protected
     procedure UpdateBounds; virtual;
@@ -174 +188 @@
     function GetVclControl: TControl; virtual;
     procedure UpdateVclControl; virtual;
-    procedure MouseDownHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
-      X, Y: Integer); virtual;
-    procedure MouseUpHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
-      X, Y: Integer); virtual;
-    procedure MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;
-    procedure MouseWheelHandler(Sender: TObject; Shift: TShiftState;
-         WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); virtual;
@@ -187 +194 @@
     procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
     procedure MouseLeave; virtual;
+    procedure MouseEnter; virtual;
   public
     function ScreenToClient(const APoint: TPoint): TPoint; virtual;
@@ -333 +341 @@
     function GetVclGraphicControl: TGraphicControl; virtual;
     procedure UpdateVclControl; override;
-    procedure UpdateVclControlPrivate; virtual;
     property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
   public
@@ -668 +675 @@
 
   TDpiPaintBox = class(TDpiGraphicControl)
-  private
-    procedure UpdateVclControlPrivate; override;
   public
     VclPaintBox: TPaintBox;
@@ -689 +694 @@
     FForms: TDpiForms;
     procedure AddForm(AForm: TDpiForm);
+    procedure RemoveForm(AForm: TDpiForm);
     function GetActiveForm: TDpiForm;
     function GetCursor: TCursor;
@@ -767 +773 @@
   end;
 
+  { TDpiMouse }
+
+  // TMouse
+  TDpiMouse = class
+  private
+    function GetCursorPos: TPoint;
+    procedure SetCursorPos(AValue: TPoint);
+  public
+    property CursorPos: TPoint read GetCursorPos write SetCursorPos;
+  end;
+
 var
   DpiFormFileDesc: TDpiFormFileDesc;
   DpiScreen: TDpiScreen;
   DpiApplication: TDpiApplication;
+  DpiMouse: TDpiMouse;
 
 procedure Register;
@@ -869 +887 @@
 end;
 
+{ TDpiMouse }
+
+function TDpiMouse.GetCursorPos: TPoint;
+begin
+  Result := ScalePointFromVcl(Mouse.CursorPos);
+end;
+
+procedure TDpiMouse.SetCursorPos(AValue: TPoint);
+begin
+  Mouse.CursorPos := ScalePointToVcl(AValue);
+end;
+
 { TDpiSizeConstraints }
 
@@ -1549 +1579 @@
 { TDpiPaintBox }
 
-procedure TDpiPaintBox.UpdateVclControlPrivate;
-begin
-  VclPaintBox.OnPaint := @PaintHandler;
-  VclPaintBox.OnMouseDown := @MouseDownHandler;
-  VclPaintBox.OnMouseUp := @MouseUpHandler;
-  VclPaintBox.OnMouseMove := @MouseMoveHandler;
-end;
-
 function TDpiPaintBox.GetVclGraphicControl: TGraphicControl;
 begin
@@ -1796 +1818 @@
 begin
   inherited;
-  UpdateVclControlPrivate;
-end;
-
-procedure TDpiGraphicControl.UpdateVclControlPrivate;
-begin
   TGraphicControlEx(GetVclGraphicControl).OnPaint := @PaintHandler;
-  TControlEx(GetVclControl).OnMouseDown := @MouseDownHandler;
-  TControlEx(GetVclControl).OnMouseUp := @MouseUpHandler;
-  TControlEx(GetVclControl).OnMouseMove := @MouseMoveHandler;
-  // Some VCL component event are not accessible on TGraphicControl level.
-  // Delegate this responsibility up
-  {
-  GetVclGraphicControl.OnPaint := @PaintHandler;
-  GetVclControl.OnMouseDown := @MouseDownHandler;
-  GetVclControl.OnMouseUp := @MouseUpHandler;
-  GetVclControl.OnMouseMove := @MouseMoveHandler;
-  }
-//  raise Exception.Create('Missing inicialization of private fields for ' + ClassName);
 end;
 
@@ -2134 +2139 @@
 end;
 
+procedure TDpiScreen.RemoveForm(AForm: TDpiForm);
+begin
+  FForms.Remove(AForm);
+  if AForm = FActiveForm then FActiveForm := nil;
+end;
+
 function TDpiScreen.GetActiveForm: TDpiForm;
 begin
@@ -2161 +2172 @@
   FForms := TDpiForms.Create;
   FForms.FreeObjects := False;
-  Dpi := 150;
+  Dpi := Round(96 * 2); //Screen.PixelsPerInch;
 end;
 
@@ -2214 +2225 @@
   GetVclControl.OnResize := @VclFormResize;
   GetVclControl.OnChangeBounds := @VclChangeBounds;
+  TControlEx(GetVclControl).OnMouseDown := @MouseDownHandler;
+  TControlEx(GetVclControl).OnMouseUp := @MouseUpHandler;
+  TControlEx(GetVclControl).OnMouseMove := @MouseMoveHandler;
+  TControlEx(GetVclControl).OnMouseEnter := @MouseEnterHandler;
+  TControlEx(GetVclControl).OnMouseLeave := @MouseLeaveHandler;
+  TControlEx(GetVclControl).OnMouseWheel := @MouseWheelHandler;
 end;
 
@@ -2244 +2261 @@
 end;
 
+procedure TDpiControl.MouseLeaveHandler(Sender: TObject);
+begin
+  MouseLeave;
+  if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
+end;
+
+procedure TDpiControl.MouseEnterHandler(Sender: TObject);
+begin
+  MouseEnter;
+  if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
+end;
+
 procedure TDpiControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
   Y: Integer);
@@ -2260 +2289 @@
 procedure TDpiControl.MouseLeave;
 begin
-
+end;
+
+procedure TDpiControl.MouseEnter;
+begin
 end;
 
@@ -2817 +2849 @@
 begin
   inherited;
-  GetVclForm.OnMouseDown := @MouseDownHandler;
-  GetVclForm.OnMouseUp := @MouseUpHandler;
-  GetVclForm.OnMouseMove := @MouseMoveHandler;
   GetVclForm.OnActivate := @ActivateHandler;
   GetVclForm.OnDeactivate := @DeactivateHandler;
@@ -2847 +2876 @@
 // Init the component with an IDE resource
 constructor TDpiForm.Create(TheOwner: TComponent);
-var
-  C: TComponent;
 begin
   //inherited;
@@ -2855 +2882 @@
   try
     CreateNew(TheOwner, 1); // this calls BeginFormUpdate, which is ended in AfterConstruction
-    // Self
-    C := FindGlobalComponent('TListDlg');
     if (ClassType <> TDpiForm) and not (csDesigning in ComponentState) then begin
       if not InitResourceComponent(Self, TDataModule) then begin
@@ -2878 +2903 @@
 begin
   FreeAndNil(VclForm);
+  DpiScreen.RemoveForm(Self);
 end;