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

Timestamp:

Apr 6, 2021, 11:03:40 PM (4 years ago)

Author:

chronos

Message:

• Fixed: Pen Width also needs to be scaled. Added TDpiPen and TDpiBrush.

File:

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

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -340 +340 @@
   end;
 
+  { TDpiPen }
+
+  TDpiPen = class
+    FWidth: Integer;
+    FNativePen: TPen;
+    FNativePenFree: Boolean;
+  private
+    function GetColor: TColor;
+    function GetStyle: TPenStyle;
+    function GetWidth: Integer;
+    procedure SetColor(AValue: TColor);
+    procedure SetNativePen(AValue: TPen);
+    procedure SetStyle(AValue: TPenStyle);
+    procedure SetWidth(AValue: Integer);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function GetNativePen: TPen;
+    property NativePen: TPen read FNativePen write SetNativePen;
+  published
+    property Color: TColor read GetColor write SetColor default clBlack;
+    property Style : TPenStyle read GetStyle write SetStyle default psSolid;
+    property Width: Integer read GetWidth write SetWidth default 1;
+  end;
+
+  { TDpiBrush }
+
+  TDpiBrush = class
+  private
+    FNativeBrush: TBrush;
+    FNativeBrushFree: Boolean;
+    function GetColor: TColor;
+    function GetStyle: TBrushStyle;
+    procedure SetColor(AValue: TColor);
+    function GetNativeBrush: TBrush;
+    procedure SetNativeBrush(AValue: TBrush);
+    procedure SetStyle(AValue: TBrushStyle);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    property NativeBrush: TBrush read FNativeBrush write SetNativeBrush;
+  published
+    property Color: TColor read GetColor write SetColor default clWhite;
+    property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
+  end;
+
   { TDpiCanvas }
 
   TDpiCanvas = class
   private
+    FBrush: TDpiBrush;
+    FBrushFree: Boolean;
+    FPen: TDpiPen;
+    FPenFree: Boolean;
     FFont: TDpiFont;
     FFontFree: Boolean;
     FNativeCanvas: TCanvas;
     FNativeCanvasFree: Boolean;
-    function GetBrush: TBrush;
     function GetHandle: HDC;
     function GetHeight: Integer;
-    function GetPen: TPen;
     function GetPixel(X, Y: Integer): TColor;
     function GetWidth: Integer;
-    procedure SetBrush(AValue: TBrush);
+    procedure SetBrush(AValue: TDpiBrush);
     procedure SetFont(AValue: TDpiFont);
     procedure SetHandle(AValue: HDC);
-    procedure SetPen(AValue: TPen);
+    procedure SetPen(AValue: TDpiPen);
     procedure SetPixel(X, Y: Integer; AValue: TColor);
     procedure SetNativeCanvas(AValue: TCanvas);
@@ -386 +434 @@
     property Height: Integer read GetHeight;
   published
-    property Brush: TBrush read GetBrush write SetBrush;
-    property Pen: TPen read GetPen write SetPen;
+    property Brush: TDpiBrush read FBrush write SetBrush;
+    property Pen: TDpiPen read FPen write SetPen;
     property Font: TDpiFont read FFont write SetFont;
   end;
@@ -1076 +1124 @@
 function ScaleToNative(Value: Integer): Integer;
 begin
-  Result := Trunc(Value * DpiScreen.Dpi / 96);
+  Result := Round(Value * DpiScreen.Dpi / 96);
 end;
 
@@ -1190 +1238 @@
  }
   {$ENDIF}
+end;
+
+{ TDpiPen }
+
+function TDpiPen.GetColor: TColor;
+begin
+  Result := GetNativePen.Color;
+end;
+
+function TDpiPen.GetStyle: TPenStyle;
+begin
+  Result := GetNativePen.Style;
+end;
+
+function TDpiPen.GetWidth: Integer;
+begin
+  Result := FWidth;
+end;
+
+procedure TDpiPen.SetColor(AValue: TColor);
+begin
+  GetNativePen.Color := AValue;
+end;
+
+procedure TDpiPen.SetNativePen(AValue: TPen);
+begin
+  if FNativePen = AValue then Exit;
+  if FNativePenFree then FreeAndNil(FNativePen);
+  FNativePenFree := False;
+  FNativePen := AValue;
+  SetWidth(FWidth);
+end;
+
+procedure TDpiPen.SetStyle(AValue: TPenStyle);
+begin
+  GetNativePen.Style := AValue;
+end;
+
+procedure TDpiPen.SetWidth(AValue: Integer);
+begin
+  GetNativePen.Width := ScaleToNative(AValue);
+  FWidth := AValue;
+end;
+
+constructor TDpiPen.Create;
+begin
+  FNativePen := TPen.Create;
+  FNativePenFree := True;
+  FWidth := 1;
+end;
+
+destructor TDpiPen.Destroy;
+begin
+  if FNativePenFree then
+    FreeAndNil(FNativePen);
+  inherited;
+end;
+
+function TDpiPen.GetNativePen: TPen;
+begin
+  Result := FNativePen;
+end;
+
+{ TDpiBrush }
+
+function TDpiBrush.GetColor: TColor;
+begin
+  Result := GetNativeBrush.Color;
+end;
+
+function TDpiBrush.GetStyle: TBrushStyle;
+begin
+  Result := GetNativeBrush.Style;
+end;
+
+procedure TDpiBrush.SetColor(AValue: TColor);
+begin
+  GetNativeBrush.Color := AValue;
+end;
+
+function TDpiBrush.GetNativeBrush: TBrush;
+begin
+  Result := FNativeBrush;
+end;
+
+procedure TDpiBrush.SetNativeBrush(AValue: TBrush);
+begin
+  if FNativeBrush = AValue then Exit;
+  if FNativeBrushFree then FreeAndNil(FNativeBrush);
+  FNativeBrushFree := False;
+  FNativeBrush := AValue;
+end;
+
+procedure TDpiBrush.SetStyle(AValue: TBrushStyle);
+begin
+  GetNativeBrush.Style := AValue;
+end;
+
+constructor TDpiBrush.Create;
+begin
+  FNativeBrush := TBrush.Create;
+  FNativeBrushFree := True;
+end;
+
+destructor TDpiBrush.Destroy;
+begin
+  if FNativeBrushFree then FreeAndNil(FNativeBrush);
+  inherited;
 end;
 
@@ -2408 +2564 @@
   Canvas := TDpiCanvas.Create;
   Canvas.NativeCanvas := NativePaintBox.Canvas;
-  Canvas.Font.NativeFont := NativePaintBox.Canvas.Font;
   UpdateNativeControl;
   ScreenChanged;
@@ -2433 +2588 @@
 { TDpiCanvas }
 
-function TDpiCanvas.GetBrush: TBrush;
-begin
-  Result := GetNativeCanvas.Brush;
-end;
-
 function TDpiCanvas.GetHandle: HDC;
 begin
@@ -2448 +2598 @@
 end;
 
-function TDpiCanvas.GetPen: TPen;
-begin
-  Result := GetNativeCanvas.Pen;
-end;
-
 function TDpiCanvas.GetPixel(X, Y: Integer): TColor;
 begin
@@ -2463 +2608 @@
 end;
 
-procedure TDpiCanvas.SetBrush(AValue: TBrush);
-begin
-  GetNativeCanvas.Brush := AValue;
+procedure TDpiCanvas.SetBrush(AValue: TDpiBrush);
+begin
+  if FBrush = AValue then Exit;
+  if FBrushFree then FreeAndNil(FBrush);
+  FBrushFree := False;
+  FBrush := AValue;
 end;
 
@@ -2481 +2629 @@
 end;
 
-procedure TDpiCanvas.SetPen(AValue: TPen);
-begin
-  GetNativeCanvas.Pen := AValue;
+procedure TDpiCanvas.SetPen(AValue: TDpiPen);
+begin
+  if FPen = AValue then Exit;
+  if FPenFree then FreeAndNil(FPen);
+  FPenFree := False;
+  FPen := AValue;
 end;
 
@@ -2510 +2661 @@
   if Assigned(FNativeCanvas) then begin
     FFont.NativeFont := FNativeCanvas.Font;
+    FBrush.NativeBrush := FNativeCanvas.Brush;
+    FPen.NativePen := FNativeCanvas.Pen;
   end;
 end;
@@ -2600 +2753 @@
   FFont := TDpiFont.Create;
   FFontFree := True;
+  FPen := TDpiPen.Create;
+  FPenFree := True;
+  FBrush := TDpiBrush.Create;
+  FBrushFree := True;
 end;
 
@@ -2605 +2762 @@
 begin
   if FFontFree then FreeAndNil(FFont);
+  if FBrushFree then FreeAndNil(FBrush);
+  if FPenFree then FreeAndNil(FPen);
   if FNativeCanvasFree then FreeAndNil(FNativeCanvasFree);
   inherited;