Changeset 252

Timestamp:

May 23, 2020, 12:45:14 AM (4 years ago)

Author:

chronos

Message:

• Fixed: Scrolling under HighDPI. ScrollDC needs to be scaled as well.

Location:

branches/highdpi

Files:

• Direct.pas (modified) (4 diffs)
• LocalPlayer/Help.pas (modified) (3 diffs)
• LocalPlayer/Select.pas (modified) (2 diffs)
• LocalPlayer/Term.pas (modified) (9 diffs)
• Packages/CevoComponents/DrawDlg.pas (modified) (4 diffs)
• Packages/DpiControls/UDpiControls.pas (modified) (2 diffs)

branches/highdpi/Direct.pas

@@ -30 +30 @@
     procedure SetInfo(x: string);
     procedure SetState(x: integer);
-    procedure OnGo(var m: TMessage); message WM_GO;
-    procedure OnChangeClient(var m: TMessage); message WM_CHANGECLIENT;
-    procedure OnNextPlayer(var m: TMessage); message WM_NEXTPLAYER;
+    procedure OnGo(var Msg: TMessage); message WM_GO;
+    procedure OnChangeClient(var Msg: TMessage); message WM_CHANGECLIENT;
+    procedure OnNextPlayer(var Msg: TMessage); message WM_NEXTPLAYER;
     procedure OnAIException(var Msg: TMessage); message WM_AIEXCEPTION;
   end;
@@ -208 +208 @@
 end;
 
-procedure TDirectDlg.OnGo(var m: TMessage);
+procedure TDirectDlg.OnGo(var Msg: TMessage);
 var
   i: integer;
@@ -234 +234 @@
         Quick := true;
         DirectHelp(cHelpOnly);
-        Close
+        Close;
       end;
     end
@@ -254 +254 @@
 end;
 
-procedure TDirectDlg.OnChangeClient(var m: TMessage);
+procedure TDirectDlg.OnChangeClient(var Msg: TMessage);
 begin
   ChangeClient;
 end;
 
-procedure TDirectDlg.OnNextPlayer(var m: TMessage);
+procedure TDirectDlg.OnNextPlayer(var Msg: TMessage);
 begin
   NextPlayer;

branches/highdpi/LocalPlayer/Help.pas

@@ -110 +110 @@
     procedure WaterSign(x0, y0, iix: Integer);
     procedure Search(SearchString: string);
-    procedure OnScroll(var m: TMessage); message WM_VSCROLL;
+    procedure OnScroll(var Msg: TMessage); message WM_VSCROLL;
     procedure OnMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
   public
@@ -342 +342 @@
 end;
 
-procedure THelpDlg.OnScroll(var m: TMessage);
+procedure THelpDlg.OnScroll(var Msg: TMessage);
 begin
   { TODO: Handled by MouseWheel event
-  if ScrollBar.Process(m) then begin
+  if ScrollBar.Process(Msg) then begin
     Sel := -1;
     SmartUpdateContent(true)
@@ -357 +357 @@
     Line(Canvas, Sel, false);
     Sel := -1
-  end
+  end;
 end;
 

branches/highdpi/LocalPlayer/Select.pas

@@ -59 +59 @@
     function RenameCity(cix: integer): boolean;
     function RenameModel(mix: integer): boolean;
-    procedure OnScroll(var m: TMessage); message WM_VSCROLL;
+    procedure OnScroll(var Msg: TMessage); message WM_VSCROLL;
     procedure OnMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
   public
@@ -133 +133 @@
 end;
 
-procedure TListDlg.OnScroll(var m: TMessage);
+procedure TListDlg.OnScroll(var Msg: TMessage);
 begin
   { TODO: Handled by MouseWheel event
-  if sb.Process(m) then  begin
+  if sb.Process(Msg) then  begin
     Sel := -2;
     SmartUpdateContent(true);

branches/highdpi/LocalPlayer/Term.pas

@@ -280 +280 @@
     procedure LoadSettings;
     procedure SaveSettings;
-    procedure OnScroll(var m: TMessage); message WM_VSCROLL;
+    procedure OnScroll(var Msg: TMessage); message WM_VSCROLL;
     procedure OnEOT(var Msg: TMessage); message WM_EOT;
     procedure SoundPreload(Check: integer);
@@ -3620 +3620 @@
 end;
 
-procedure TMainScreen.OnScroll(var m: TMessage);
-begin
-  if sb.Process(m) then begin
+procedure TMainScreen.OnScroll(var Msg: TMessage);
+begin
+  if sb.Process(Msg) then begin
     PanelPaint;
     Update;
@@ -3630 +3630 @@
 procedure TMainScreen.OnEOT(var Msg: TMessage);
 begin
-  EndTurn
+  EndTurn;
 end;
 
@@ -3638 +3638 @@
   begin
     MessgExDlg.CancelMovie;
-    Server(sBreak, me, 0, nil^)
+    Server(sBreak, me, 0, nil^);
   end
   else if ClientMode < 0 then
@@ -3647 +3647 @@
   begin
     Jump[pTurn] := 0;
-    StartRunning := false
+    StartRunning := false;
   end
   else
-    EndTurn
+    EndTurn;
 end;
 
@@ -4144 +4144 @@
 end;
 
-{$IFDEF LINUX}
-// Can't do scrolling of DC under Linux, then fallback into BitBlt.
-function ScrollDC(Canvas: TDpiCanvas; dx: longint; dy: longint; const lprcScroll:TRect; const lprcClip:TRect; hrgnUpdate:HRGN; lprcUpdate: PRect):Boolean;
-begin
-  Result := DpiBitCanvas(Canvas, lprcScroll.Left + dx, lprcScroll.Top + dy, lprcScroll.Right - lprcScroll.Left, lprcScroll.Bottom - lprcScroll.Top,
-    Canvas, lprcScroll.Left, lprcScroll.Top);
-end;
-{$ENDIF}
-
 procedure TMainScreen.MainOffscreenPaint;
 var
@@ -4199 +4190 @@
     offscreen.Canvas.Font.Assign(UniFont[ftSmall]);
     rec := Rect(0, 0, MapWidth, MapHeight);
-{$IFDEF WINDOWS}
-    ScrollDC(offscreen.Canvas.Handle, (xwd - xw) * (xxt * 2), (ywd - yw) * yyt,
+    DpiScrollDC(offscreen.Canvas.Handle, (xwd - xw) * (xxt * 2), (ywd - yw) * yyt,
       rec, rec, 0, nil);
-{$ENDIF}
-{$IFDEF LINUX}
-    ScrollDC(offscreen.Canvas, (xwd - xw) * (xxt * 2), (ywd - yw) * yyt,
-      rec, rec, 0, nil);
-{$ENDIF}
     for DoInvalidate := false to FastScrolling do
     begin
@@ -4212 +4197 @@
       begin
         rec.Bottom := MapHeight - overlap;
-{$IFDEF WINDOWS}
-        ScrollDC(Canvas.Handle, (xwd - xw) * (xxt * 2), (ywd - yw) * yyt, rec,
+        DpiScrollDC(Canvas.Handle, (xwd - xw) * (xxt * 2), (ywd - yw) * yyt, rec,
           rec, 0, nil);
-{$ENDIF}
-{$IFDEF LINUX}
-        ScrollDC(Canvas, (xwd - xw) * (xxt * 2), (ywd - yw) * yyt,
-          rec, rec, 0, nil);
-{$ENDIF}
         ProcessOptions := prInvalidate;
       end
@@ -5074 +5053 @@
           if DpiMouse.CursorPos.x = 0 then
             dx := -speed // scroll left
-          else if DpiMouse.CursorPos.x = DpiScreen.width - 1 then
+          else if DpiMouse.CursorPos.x >= DpiScreen.width - 1 then
             dx := speed; // scroll right
         if DpiMouse.CursorPos.y = 0 then
           dy := -speed // scroll up
-        else if (DpiMouse.CursorPos.y = DpiScreen.height - 1) and
+        else if (DpiMouse.CursorPos.y >= DpiScreen.height - 1) and
           (DpiMouse.CursorPos.x >= TerrainBtn.Left + TerrainBtn.width) and
           (DpiMouse.CursorPos.x < xRightPanel + 10 - 8) then

branches/highdpi/Packages/CevoComponents/DrawDlg.pas

@@ -22 +22 @@
     // defines area to grip the window for moving (from top)
     procedure InitButtons;
-    procedure OnEraseBkgnd(var m: TMessage); message WM_ERASEBKGND;
+    procedure OnEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
     procedure OnHitTest(var Msg: TMessage); message WM_NCHITTEST;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
@@ -79 +79 @@
 end;
 
-procedure TDrawDlg.OnEraseBkgnd(var m: TMessage);
+procedure TDrawDlg.OnEraseBkgnd(var Msg: TMessage);
 begin
 end;
@@ -93 +93 @@
   else
   begin
-    Pos := Point(Integer(Msg.LParam and $ffff),
-      Integer((Msg.LParam shr 16) and $ffff));
+    Pos := ScalePointFromNative(Point(Integer(Msg.LParam and $ffff),
+      Integer((Msg.LParam shr 16) and $ffff)));
     if Pos.Y >= Top + TitleHeight then
       Msg.Result := HTCLIENT
@@ -112 +112 @@
           end;
         end;
-      Msg.Result := HTCAPTION
+      Msg.Result := HTCAPTION;
     end;
   end;

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -902 +902 @@
 function DpiBitBltCanvas(Dest: TDpiCanvas; X, Y, Width, Height: Integer; Src: TDpiCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
 function DpiCreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
+function DpiScrollDC(hDC:HDC; dx:longint; dy:longint; const lprcScroll:RECT; const lprcClip:RECT;hrgnUpdate:HRGN; lprcUpdate: LPRECT): WINBOOL;
 function ScaleToNative(Value: Integer): Integer;
 function ScaleFromNative(Value: Integer): Integer;
@@ -940 +941 @@
   Result := CreateRectRgn(ScaleToNative(X1), ScaleToNative(Y1), ScaleToNative(X2),
     ScaleToNative(Y2));
+end;
+
+{$IFDEF LINUX}
+function LinuxScrollDC(Canvas: TDpiCanvas; dx: longint; dy: longint; const lprcScroll:TRect; const lprcClip:TRect; hrgnUpdate:HRGN; lprcUpdate: PRect):Boolean;
+begin
+end;
+{$ENDIF}
+
+function DpiScrollDC(hDC: HDC; dx: longint; dy: longint;
+  const lprcScroll: RECT; const lprcClip: RECT; hrgnUpdate: HRGN;
+  lprcUpdate: LPRECT): WINBOOL;
+begin
+  {$IFDEF WINDOWS}
+  Result := Windows.ScrollDC(hDC, ScaleToNative(dx), ScaleToNative(dy),
+    ScaleRectToNative(lprcScroll), ScaleRectToNative(lprcClip),
+    hrgnUpdate, lprcUpdate);
+  {$ENDIF}
+  {$IFDEF LINUX}
+  // Can't do scrolling of DC under Linux, then fallback into BitBlt.
+  Result := DpiBitCanvas(Canvas, lprcScroll.Left + dx, lprcScroll.Top + dy, lprcScroll.Right - lprcScroll.Left, lprcScroll.Bottom - lprcScroll.Top,
+    Canvas, lprcScroll.Left, lprcScroll.Top);
+  {$ENDIF}
 end;