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

Timestamp:

May 7, 2020, 7:05:57 PM (4 years ago)

Author:

chronos

Message:

• Modified: Improved code in HighDPI branch.

File:

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

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -28 +28 @@
   public
     property OnPaint;
+    procedure Paint; override;
+  end;
+
+  { TControlEx }
+
+  TControlEx = class(TControl)
+  public
     property OnMouseDown;
     property OnMouseUp;
     property OnMouseMove;
-    procedure Paint; override;
   end;
 
@@ -189 +195 @@
     property Parent: TDpiWinControl read FParent write SetParent;
     property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
+    property Visible: Boolean read GetVisible write SetVisible;
   published
     property ClientHeight: Integer read GetClientHeight write SetClientHeight;
@@ -197 +204 @@
     property Width: Integer read FWidth write SetWidth;
     property Height: Integer read FHeight write SetHeight;
-    property Visible: Boolean read GetVisible write SetVisible;
     property Caption: string read GetCaption write SetCaption;
     property Enabled: Boolean read GetEnabled write SetEnabled;
@@ -221 +227 @@
   TDpiGraphic = class(TPersistent)
   protected
+    FDpi: Integer;
     function GetVclGraphic: TGraphic; virtual;
+    function GetWidth: Integer; virtual; abstract;
+    function GetHeight: Integer; virtual; abstract;
+    procedure SetWidth(Value: Integer); virtual; abstract;
+    procedure SetHeight(Value: Integer); virtual; abstract;
+    procedure ScreenChanged; virtual;
+    procedure SetDpi(AValue: Integer); virtual;
+    function GetDpi: Integer; virtual;
   public
-    procedure LoadFromFile(const Filename: string);
+    constructor Create;
+    procedure LoadFromFile(const Filename: string); virtual;
+    property Width: Integer read GetWidth write SetWidth;
+    property Height: Integer read GetHeight write SetHeight;
+    property Dpi: Integer read GetDpi write SetDpi;
   end;
 
@@ -260 +278 @@
     procedure StretchDraw(const DestRect: TRect; SrcGraphic: TDpiGraphic); virtual;
     procedure FrameRect(Rect: TRect);
-    procedure Rectangle(X1, Y1, X2, Y2: Integer);
+    procedure Rectangle(X1, Y1, X2, Y2: Integer); overload;
+    procedure Rectangle(const ARect: TRect); overload;
     function TextWidth(Text: string): Integer;
     function TextHeight(Text: string): Integer;
@@ -291 +310 @@
     VclGraphicControl: TGraphicControl;
     FCanvas: TDpiCanvas;
+    function GetOnPaint: TNotifyEvent;
     procedure SetCanvas(AValue: TDpiCanvas);
     procedure PaintHandler(Sender: TObject);
+    procedure SetOnPaint(AValue: TNotifyEvent);
   protected
     procedure Paint; virtual;
@@ -298 +319 @@
     function GetVclGraphicControl: TGraphicControl; virtual;
     procedure UpdateVclControl; override;
-    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
+    procedure UpdateVclControlPrivate; virtual;
+    property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
   public
     constructor Create(TheOwner: TComponent); override;
@@ -481 +503 @@
     destructor Destroy; override;
   published
+    property Visible;
   end;
 
@@ -523 +546 @@
     property ExtendedSelect: Boolean read GetExtendedSelect write SetExtendedSelect default true;
     property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle default bsNone;
+    property Visible;
   end;
 
@@ -556 +580 @@
     property Kind: TScrollBarKind read GetKind write SetKind;
     property OnChange: TNotifyEvent read GetOnChange write SetOnChange;
+    property Visible;
   end;
 
@@ -563 +588 @@
   private
     FCanvas: TDpiCanvas;
+    FWidth: Integer;
+    FHeight: Integer;
     function GetCanvas: TDpiCanvas;
-    function GetHeight: Integer;
     function GetPixelFormat: TPixelFormat;
     function GetScanLine(Row: Integer): Pointer;
-    function GetWidth: Integer;
-    procedure SetHeight(AValue: Integer);
     procedure SetPixelFormat(AValue: TPixelFormat);
-    procedure SetWidth(AValue: Integer);
   protected
+    function GetHeight: Integer; override;
+    function GetWidth: Integer; override;
     function GetVclBitmap: TCustomBitmap; virtual;
     function GetVclRasterImage: TRasterImage; override;
+    procedure SetHeight(AValue: Integer); override;
+    procedure SetWidth(AValue: Integer); override;
+    procedure ScreenChanged; override;
   public
     VclBitmap: TBitmap;
     procedure BeginUpdate;
     procedure EndUpdate;
-    procedure SetSize(Width, Height: Integer);
+    procedure SetSize(AWidth, AHeight: Integer);
     constructor Create;
     destructor Destroy; override;
@@ -617 +645 @@
     property Stretch: Boolean read FStretch write SetStretch;
     property Picture: TDpiPicture read FDpiPicture write SetPicture;
+    property Visible;
   end;
 
@@ -623 +652 @@
   TDpiPaintBox = class(TDpiGraphicControl)
   private
-    function GetOnPaint: TNotifyEvent;
-    procedure SetOnPaint(AValue: TNotifyEvent);
+    procedure UpdateVclControlPrivate; override;
   public
     VclPaintBox: TPaintBox;
@@ -631 +659 @@
     destructor Destroy; override;
   published
+    property OnPaint;
+    property Visible;
   end;
 
@@ -666 +696 @@
   public
     VclJpeg: TJPEGImage;
+    procedure LoadFromFile(const Filename: string); override;
   end;
 
@@ -676 +707 @@
   public
     VclPng: TPortableNetworkGraphic;
+    procedure LoadFromFile(const Filename: string); override;
   end;
 
@@ -709 +741 @@
 
 procedure Register;
-function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
+function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
+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 ScaleToVcl(Value: Integer): Integer;
@@ -735 +768 @@
 end;
 
+function DpiBitBltCanvas(Dest: TDpiCanvas; X, Y, Width, Height: Integer;
+  Src: TDpiCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
+begin
+  Result := DpiBitBlt(Dest.Handle, X, Y, Width, Height, Src.Handle, XSrc, YSrc, Rop);
+end;
+
 function DpiCreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
 begin
@@ -792 +831 @@
 
 function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
-  YSrc: Integer; Rop: DWORD): Boolean;
+  YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
 begin
   Result := BitBlt(DestDC, ScaleToVcl(X), ScaleToVcl(Y), ScaleToVcl(Width),
@@ -995 +1034 @@
 end;
 
+procedure TDpiJpegImage.LoadFromFile(const Filename: string);
+var
+  Bitmap: TJPEGImage;
+begin
+  Bitmap := TJPEGImage.Create;
+  Bitmap.LoadFromFile(FileName);
+  Width := ScaleFromVcl(Bitmap.Width);
+  Height := ScaleFromVcl(Bitmap.Height);
+  if Self is TDpiBitmap then
+    TBitmap(GetVclGraphic).Canvas.StretchDraw(Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap)
+    else raise Exception.Create('Unsupported class ' + Self.ClassName);
+  Bitmap.Free;
+end;
+
 { TDpiPortableNetworkGraphic }
 
@@ -1006 +1059 @@
   if not Assigned(VclPng) then VclPng := TPortableNetworkGraphic.Create;
   Result := VclPng;
+end;
+
+procedure TDpiPortableNetworkGraphic.LoadFromFile(const Filename: string);
+var
+  Bitmap: TPortableNetworkGraphic;
+begin
+  Bitmap := TPortableNetworkGraphic.Create;
+  Bitmap.LoadFromFile(FileName);
+  Width := ScaleFromVcl(Bitmap.Width);
+  Height := ScaleFromVcl(Bitmap.Height);
+  if Self is TDpiBitmap then
+    TBitmap(GetVclGraphic).Canvas.StretchDraw(Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap)
+    else raise Exception.Create('Unsupported class ' + Self.ClassName);
+  Bitmap.Free;
 end;
 
@@ -1157 +1224 @@
 end;
 
+procedure TDpiGraphic.ScreenChanged;
+begin
+end;
+
+procedure TDpiGraphic.SetDpi(AValue: Integer);
+begin
+  FDpi := AValue;
+  ScreenChanged;
+end;
+
+function TDpiGraphic.GetDpi: Integer;
+begin
+  Result := FDpi;
+end;
+
+constructor TDpiGraphic.Create;
+begin
+  Dpi := DpiScreen.Dpi;
+end;
+
 procedure TDpiGraphic.LoadFromFile(const Filename: string);
-begin
-  GetVclGraphic.LoadFromFile(FileName);
+var
+  Bitmap: TBitmap;
+begin
+  Bitmap := TBitmap.Create;
+  Bitmap.LoadFromFile(FileName);
+  Width := ScaleFromVcl(Bitmap.Width);
+  Height := ScaleFromVcl(Bitmap.Height);
+  if Self is TDpiBitmap then
+    TBitmap(GetVclGraphic).Canvas.StretchDraw(Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap)
+    else raise Exception.Create('Unsupported class ' + Self.ClassName);
+  Bitmap.Free;
 end;
 
@@ -1166 +1262 @@
 function TDpiBitmap.GetHeight: Integer;
 begin
-  Result := ScaleFromVcl(GetVclBitmap.Height);
+  Result := FHeight;
 end;
 
@@ -1190 +1286 @@
 function TDpiBitmap.GetWidth: Integer;
 begin
-  Result := ScaleFromVcl(GetVclBitmap.Width);
+  Result := FWidth;
 end;
 
 procedure TDpiBitmap.SetHeight(AValue: Integer);
 begin
+  FHeight := AValue;
   GetVclBitmap.Height := ScaleToVcl(AValue);
 end;
@@ -1205 +1302 @@
 procedure TDpiBitmap.SetWidth(AValue: Integer);
 begin
+  FWidth := AValue;
   GetVclBitmap.Width := ScaleToVcl(AValue);
+end;
+
+procedure TDpiBitmap.ScreenChanged;
+var
+  Bitmap: TBitmap;
+  NewWidth: Integer;
+  NewHeight: Integer;
+begin
+  NewWidth := ScaleToVcl(Width);
+  NewHeight := ScaleToVcl(Height);
+  if Assigned(VclBitmap) and ((NewWidth <> VclBitmap.Width) or (NewHeight <> VclBitmap.Height)) then begin
+    // Rescale bitmap to new size
+    Bitmap := TBitmap.Create;
+    Bitmap.SetSize(NewWidth, NewHeight);
+    Bitmap.PixelFormat := VclBitmap.PixelFormat;
+    Bitmap.Canvas.StretchDraw(Bounds(0, 0, NewWidth, NewHeight), VclBitmap);
+    VclBitmap.Free;
+    VclBitmap := Bitmap;
+    Canvas.VclCanvas := VclBitmap.Canvas;
+  end;
 end;
 
@@ -1227 +1345 @@
 end;
 
-procedure TDpiBitmap.SetSize(Width, Height: Integer);
-begin
-  GetVclBitmap.SetSize(ScaleToVcl(Width), ScaleToVcl(Height));
+procedure TDpiBitmap.SetSize(AWidth, AHeight: Integer);
+begin
+  FWidth := AWidth;
+  FHeight := AHeight;
+  GetVclBitmap.SetSize(ScaleToVcl(AWidth), ScaleToVcl(AHeight));
 end;
 
@@ -1372 +1492 @@
 { TDpiPaintBox }
 
-function TDpiPaintBox.GetOnPaint: TNotifyEvent;
-begin
-  Result := VclPaintBox.OnPaint;
-end;
-
-procedure TDpiPaintBox.SetOnPaint(AValue: TNotifyEvent);
-begin
-  VclPaintBox.OnPaint := AValue;
+procedure TDpiPaintBox.UpdateVclControlPrivate;
+begin
+  VclPaintBox.OnPaint := @PaintHandler;
+  VclPaintBox.OnMouseDown := @MouseDownHandler;
+  VclPaintBox.OnMouseUp := @MouseUpHandler;
+  VclPaintBox.OnMouseMove := @MouseMoveHandler;
 end;
 
@@ -1416 +1534 @@
 end;
 
-
 { TDpiCanvas }
 
@@ -1471 +1588 @@
 
 procedure TDpiCanvas.SetPixel(X, Y: Integer; AValue: TColor);
-begin
+var
+  BrushStyle: TBrushStyle;
+  BrushColor: TColor;
+begin
+ { BrushStyle := GetVclCanvas.Brush.Style;
+  BrushColor := GetVclCanvas.Brush.Color;
+  GetVclCanvas.Brush.Color := AValue;
+  GetVclCanvas.Brush.Style := bsClear;
+  GetVclCanvas.FillRect(ScaleToVcl(X), ScaleToVcl(Y), ScaleToVcl(X + 1) - 1, ScaleToVcl(Y + 1) - 1);
+  GetVclCanvas.Brush.Style := BrushStyle;
+  GetVclCanvas.Brush.Color := BrushColor;
+  }
   GetVclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)] := AValue;
 end;
@@ -1497 +1625 @@
 end;
 
+procedure TDpiCanvas.Rectangle(const ARect: TRect);
+begin
+  Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
+end;
+
 function TDpiCanvas.TextWidth(Text: string): Integer;
 begin
@@ -1550 +1683 @@
   Source: TRect);
 begin
-  GetVclCanvas.CopyRect(Dest, SrcCanvas.VclCanvas, Source);
+  GetVclCanvas.CopyRect(Dest, SrcCanvas.VclCanvas, ScaleRectToVcl(Source));
 end;
 
@@ -1591 +1724 @@
 begin
   if not Assigned(VclGraphicControl) then begin
-    VclGraphicControl := TGraphicControlEx.Create(nil);
-    (VclGraphicControl as TGraphicControlEx).OnPaint := @PaintHandler;
+    VclGraphicControl := TGraphicControl.Create(nil);
   end;
   Result := VclGraphicControl;
@@ -1600 +1732 @@
 begin
   inherited;
-  (GetVclGraphicControl as TGraphicControlEx).OnMouseDown := @MouseDownHandler;
-  (GetVclGraphicControl as TGraphicControlEx).OnMouseUp := @MouseUpHandler;
-  (GetVclGraphicControl as TGraphicControlEx).OnMouseMove := @MouseMoveHandler;
+  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;
+
+function TDpiGraphicControl.GetOnPaint: TNotifyEvent;
+begin
+  Result := FOnPaint;
+end;
+
+procedure TDpiGraphicControl.SetOnPaint(AValue: TNotifyEvent);
+begin
+  FOnPaint := AValue;
 end;
 
@@ -1906 +2063 @@
   Forms := TDpiForms.Create;
   Forms.FreeObjects := False;
-  Dpi := 144;
+  Dpi := 150;
 end;
 
@@ -1914 +2071 @@
   inherited Destroy;
 end;
-
-{ TDpiWinControl }
-
 
 { TDpiButton }
@@ -2513 +2667 @@
 begin
   if not Assigned(VclForm) then begin
-    VclForm := TFormEx.Create(nil);
+    VclForm := TFormEx.CreateNew(nil);
     (VclForm as TFormEx).OnMessage := @FormMessageHandler;
     //VclForm := TForm.Create(nil);