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

Timestamp:

May 9, 2020, 4:02:07 PM (5 years ago)

Author:

chronos

Message:

• Modified: Improved HighDPI branch. Imported new changes from trunk branch.

File:

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

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -131 +131 @@
     FParent: TDpiWinControl;
     function GetAlign: TAlign;
+    function GetAnchors: TAnchors;
     function GetBoundsRect: TRect;
     function GetClientHeight: Integer;
@@ -141 +142 @@
     function GetShowHint: Boolean;
     function GetVisible: Boolean;
+    function IsAnchorsStored: Boolean;
     procedure SetAlign(AValue: TAlign);
+    procedure SetAnchors(AValue: TAnchors);
     procedure SetBoundsRect(AValue: TRect);
     procedure SetClientHeight(AValue: Integer);
@@ -183 +186 @@
       X, Y: Integer); virtual;
     procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
+    procedure MouseLeave; virtual;
   public
+    function ScreenToClient(const APoint: TPoint): TPoint; virtual;
+    function ClientToScreen(const APoint: TPoint): TPoint; virtual;
+    procedure AddHandlerOnVisibleChanged(const OnVisibleChangedEvent: TNotifyEvent;
+                                         AsFirst: boolean = false);
+    procedure RemoveHandlerOnVisibleChanged(const OnVisibleChangedEvent: TNotifyEvent);
     procedure ScreenChanged; virtual;
     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual;
@@ -196 +205 @@
     property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
     property Visible: Boolean read GetVisible write SetVisible;
+    property Anchors: TAnchors read GetAnchors write SetAnchors stored IsAnchorsStored default [akLeft, akTop];
   published
     property ClientHeight: Integer read GetClientHeight write SetClientHeight;
@@ -237 +247 @@
     function GetDpi: Integer; virtual;
   public
-    constructor Create;
+    VclGraphicClass: TGraphicClass;
+    constructor Create; virtual;
     procedure LoadFromFile(const Filename: string); virtual;
+    procedure SaveToFile(const Filename: string); virtual;
     property Width: Integer read GetWidth write SetWidth;
     property Height: Integer read GetHeight write SetHeight;
@@ -261 +273 @@
   private
     FFont: TDpiFont;
+    FVclCanvas: TCanvas;
     function GetBrush: TBrush;
     function GetHandle: HDC;
@@ -272 +285 @@
     procedure SetPen(AValue: TPen);
     procedure SetPixel(X, Y: Integer; AValue: TColor);
+    procedure SetVclCanvas(AValue: TCanvas);
   protected
     function GetVclCanvas: TCanvas; virtual;
   public
-    VclCanvas: TCanvas;
+    property VclCanvas: TCanvas read FVclCanvas write SetVclCanvas;
     procedure StretchDraw(const DestRect: TRect; SrcGraphic: TDpiGraphic); virtual;
     procedure FrameRect(Rect: TRect);
@@ -458 +472 @@
     function GetVclForm: TForm; virtual;
     procedure UpdateVclControl; override;
+    procedure AfterConstruction; override;
   public
     VclForm: TForm;
@@ -465 +480 @@
     procedure BringToFront;
     constructor Create(TheOwner: TComponent); override;
+    constructor CreateNew(AOwner: TComponent; Num: Integer = 0); virtual;
     destructor Destroy; override;
   published
@@ -547 +563 @@
     property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle default bsNone;
     property Visible;
+    property Anchors;
   end;
 
@@ -607 +624 @@
     procedure EndUpdate;
     procedure SetSize(AWidth, AHeight: Integer);
-    constructor Create;
+    constructor Create; override;
     destructor Destroy; override;
     procedure Assign(Source: TPersistent); override;
@@ -667 +684 @@
   TDpiScreen = class
   private
+    // TScreen
     FDpi: Integer;
     FActiveForm: TDpiForm;
+    FForms: TDpiForms;
+    procedure AddForm(AForm: TDpiForm);
     function GetActiveForm: TDpiForm;
+    function GetCursor: TCursor;
+    function GetCursors(Index: Integer): HCURSOR;
     function GetFormCount: Integer;
+    function GetForms(Index: Integer): TDpiForm;
     function GetHeight: Integer;
     function GetWidth: Integer;
     procedure SetActiveForm(AValue: TDpiForm);
+    procedure SetCursor(AValue: TCursor);
+    procedure SetCursors(Index: Integer; AValue: HCURSOR);
     procedure SetDpi(AValue: Integer);
     procedure UpdateForms;
   public
-    Forms: TDpiForms;
     constructor Create;
     destructor Destroy; override;
     property FormCount: Integer read GetFormCount;
+    property Forms[Index: Integer]: TDpiForm read GetForms;
     property ActiveForm: TDpiForm read GetActiveForm write SetActiveForm;
+    property Cursor: TCursor read GetCursor write SetCursor;
+    property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
   published
     property Dpi: Integer read FDpi write SetDpi;
+    property PixelsPerInch: Integer read FDpi;
     property Width: Integer read GetWidth;
     property Height: Integer read GetHeight;
@@ -696 +724 @@
   public
     VclJpeg: TJPEGImage;
-    procedure LoadFromFile(const Filename: string); override;
+    constructor Create; override;
   end;
 
@@ -707 +735 @@
   public
     VclPng: TPortableNetworkGraphic;
-    procedure LoadFromFile(const Filename: string); override;
+    constructor Create; override;
   end;
 
@@ -716 +744 @@
     FMainForm: TDpiForm;
     FCreatingForm: TDpiForm;
+    function GetActive: Boolean;
     function GetShowMainForm: Boolean;
     function GetTitle: string;
@@ -725 +754 @@
     function GetVclApplication: TApplication; virtual;
   public
+    constructor Create(AOwner: TComponent); override;
     procedure Run;
     procedure Initialize;
@@ -730 +760 @@
     procedure UpdateMainForm(AForm: TDpiForm);
     procedure CreateForm(InstanceClass: TComponentClass; out Reference);
+    function MessageBox(Text, Caption: PChar; Flags: Longint = MB_OK): Integer;
     property MainForm: TDpiForm read GetMainForm write SetMainForm;
     property ShowMainForm: Boolean read GetShowMainForm write SetShowMainForm default True;
     property Title: string read GetTitle write SetTitle;
+    property Active: Boolean read GetActive;
   end;
 
@@ -934 +966 @@
 end;
 
+function TDpiApplication.GetActive: Boolean;
+begin
+  Result := Application.Active;
+end;
+
 function TDpiApplication.GetMainForm: TDpiForm;
 begin
@@ -952 +989 @@
 begin
   Result := Application;
+end;
+
+function DpiFindApplicationComponent(const ComponentName: string): TComponent;
+// Note: this function is used by TReader to auto rename forms to unique names.
+begin
+  Result := DpiApplication.FindComponent(ComponentName);
+end;
+
+constructor TDpiApplication.Create(AOwner: TComponent);
+begin
+  RegisterFindGlobalComponentProc(@DpiFindApplicationComponent);
+  inherited;
 end;
 
@@ -1021 +1070 @@
 end;
 
+function TDpiApplication.MessageBox(Text, Caption: PChar; Flags: Longint
+  ): Integer;
+begin
+  Result := Application.MessageBox(Text, Caption, Flags);
+end;
+
 { TDpiJpegImage }
 
@@ -1034 +1089 @@
 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;
+constructor TDpiJpegImage.Create;
+begin
+  inherited;
+  VclGraphicClass := TJPEGImage;
 end;
 
@@ -1061 +1108 @@
 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;
+constructor TDpiPortableNetworkGraphic.Create;
+begin
+  inherited;
+  VclGraphicClass := TPortableNetworkGraphic;
 end;
 
@@ -1246 +1285 @@
 procedure TDpiGraphic.LoadFromFile(const Filename: string);
 var
-  Bitmap: TBitmap;
-begin
-  Bitmap := TBitmap.Create;
+  Bitmap: TGraphic;
+begin
+  Bitmap := VclGraphicClass.Create;
   Bitmap.LoadFromFile(FileName);
-  Width := ScaleFromVcl(Bitmap.Width);
-  Height := ScaleFromVcl(Bitmap.Height);
+  Width := Bitmap.Width;
+  Height := Bitmap.Height;
   if Self is TDpiBitmap then
-    TBitmap(GetVclGraphic).Canvas.StretchDraw(Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap)
+    TBitmap(GetVclGraphic).Canvas.StretchDraw(Bounds(0, 0,
+    TBitmap(GetVclGraphic).Width, TBitmap(GetVclGraphic).Height), Bitmap)
     else raise Exception.Create('Unsupported class ' + Self.ClassName);
+  Bitmap.Free;
+end;
+
+procedure TDpiGraphic.SaveToFile(const Filename: string);
+var
+  Bitmap: TGraphic;
+begin
+  Bitmap := VclGraphicClass.Create;
+  Bitmap.Width := Width;
+  Bitmap.Height := Height;
+  if Self is TDpiBitmap then begin
+    if Bitmap is TRasterImage then
+      (Bitmap as TRasterImage).Canvas.StretchDraw(Bounds(0, 0, Bitmap.Width, Bitmap.Height), TBitmap(GetVclGraphic))
+      else raise Exception.Create('Expected TRasterImage but got ' + Bitmap.ClassName);
+  end else raise Exception.Create('Unsupported class ' + Self.ClassName);
+  Bitmap.SaveToFile(FileName);
   Bitmap.Free;
 end;
@@ -1355 +1411 @@
 begin
   inherited;
+  VclGraphicClass := TBitmap;
 end;
 
@@ -1601 +1658 @@
   }
   GetVclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)] := AValue;
+end;
+
+procedure TDpiCanvas.SetVclCanvas(AValue: TCanvas);
+begin
+  if FVclCanvas = AValue then Exit;
+  FVclCanvas := AValue;
+  FFont.VclFont := FVclCanvas.Font;
 end;
 
@@ -1809 +1873 @@
   if FSize = AValue then Exit;
   FSize := AValue;
+  GetVclFont.Size := AValue;
   DoChange;
 end;
@@ -2036 +2101 @@
 end;
 
+procedure TDpiScreen.SetCursor(AValue: TCursor);
+begin
+  Screen.Cursor := AValue;
+end;
+
+procedure TDpiScreen.SetCursors(Index: Integer; AValue: HCURSOR);
+begin
+  Screen.Cursors[Index] := AValue;
+end;
+
 function TDpiScreen.GetHeight: Integer;
 begin
@@ -2043 +2118 @@
 function TDpiScreen.GetFormCount: Integer;
 begin
-  Result := Forms.Count;
+  Result := FForms.Count;
+end;
+
+function TDpiScreen.GetForms(Index: Integer): TDpiForm;
+begin
+  Result := FForms[Index];
+end;
+
+procedure TDpiScreen.AddForm(AForm: TDpiForm);
+begin
+  if AForm is TDpiForm then begin
+    FForms.Add(AForm);
+    //DpiApplication.UpdateVisible;
+  end;
 end;
 
@@ -2049 +2137 @@
 begin
   Result := FActiveForm;
+end;
+
+function TDpiScreen.GetCursor: TCursor;
+begin
+  Result := Screen.Cursor;
+end;
+
+function TDpiScreen.GetCursors(Index: Integer): HCURSOR;
+begin
+  Result := Screen.Cursors[Index];
 end;
 
@@ -2055 +2153 @@
   I: Integer;
 begin
-  for I := 0 to Forms.Count - 1 do
-    Forms[I].ScreenChanged;
+  for I := 0 to FForms.Count - 1 do
+    FForms[I].ScreenChanged;
 end;
 
 constructor TDpiScreen.Create;
 begin
-  Forms := TDpiForms.Create;
-  Forms.FreeObjects := False;
+  FForms := TDpiForms.Create;
+  FForms.FreeObjects := False;
   Dpi := 150;
 end;
@@ -2068 +2166 @@
 destructor TDpiScreen.Destroy;
 begin
-  FreeAndNil(Forms);
+  FreeAndNil(FForms);
   inherited Destroy;
 end;
@@ -2158 +2256 @@
 procedure TDpiControl.MouseMove(Shift: TShiftState; X, Y: Integer);
 begin
+end;
+
+procedure TDpiControl.MouseLeave;
+begin
+
+end;
+
+function TDpiControl.ScreenToClient(const APoint: TPoint): TPoint;
+begin
+  Result := ScalePointFromVcl(GetVclControl.ScreenToClient(ScalePointToVcl(APoint)));
+end;
+
+function TDpiControl.ClientToScreen(const APoint: TPoint): TPoint;
+begin
+  Result := ScalePointFromVcl(GetVclControl.ClientToScreen(ScalePointToVcl(APoint)));
+end;
+
+procedure TDpiControl.AddHandlerOnVisibleChanged(
+  const OnVisibleChangedEvent: TNotifyEvent; AsFirst: boolean);
+begin
+  GetVclControl.AddHandlerOnVisibleChanged(OnVisibleChangedEvent, AsFirst);
+end;
+
+procedure TDpiControl.RemoveHandlerOnVisibleChanged(
+  const OnVisibleChangedEvent: TNotifyEvent);
+begin
+  GetVclControl.RemoveHandlerOnVisibleChanged(OnVisibleChangedEvent);
 end;
 
@@ -2272 +2397 @@
 end;
 
+function TDpiControl.GetAnchors: TAnchors;
+begin
+  Result := GetVclControl.Anchors;
+end;
+
 function TDpiControl.GetClientHeight: Integer;
 begin
@@ -2317 +2447 @@
 end;
 
+function TDpiControl.IsAnchorsStored: Boolean;
+begin
+
+end;
+
 procedure TDpiControl.SetAlign(AValue: TAlign);
 begin
   GetVclControl.Align := AValue;
+end;
+
+procedure TDpiControl.SetAnchors(AValue: TAnchors);
+begin
+  GetVclControl.Anchors := AValue;
 end;
 
@@ -2684 +2824 @@
 end;
 
+procedure TDpiForm.AfterConstruction;
+begin
+  inherited;
+  DoOnCreate;
+end;
+
 function TDpiForm.ShowModal: Integer;
 begin
@@ -2701 +2847 @@
 // Init the component with an IDE resource
 constructor TDpiForm.Create(TheOwner: TComponent);
-begin
-  inherited;
+var
+  C: TComponent;
+begin
+  //inherited;
   //DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);
   GlobalNameSpace.BeginWrite;
   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
@@ -2716 +2867 @@
   ScreenChanged;
   UpdateVclControl;
-  DoOnCreate;
+end;
+
+constructor TDpiForm.CreateNew(AOwner: TComponent; Num: Integer);
+begin
+  inherited Create(AOwner);
+  DpiScreen.AddForm(Self);
 end;