Changeset 535


Ignore:
Timestamp:
May 27, 2019, 12:06:17 AM (5 years ago)
Author:
chronos
Message:
  • Added: More DPI aware components.
Location:
DpiControls
Files:
6 edited

Legend:

Unmodified
Added
Removed

  • DpiControls/Demo/DpiComponentsDemo.lpi

    r534 r535  
    1515      <Icon Value="0"/>
    1616    </General>
    17     <BuildModes Count="1">
    18       <Item1 Name="Default" Default="True"/>
     17    <BuildModes Count="2">
     18      <Item1 Name="Debug" Default="True"/>
     19      <Item2 Name="Release">
     20        <CompilerOptions>
     21          <Version Value="11"/>
     22          <Target>
     23            <Filename Value="DpiComponentsDemo"/>
     24          </Target>
     25          <SearchPaths>
     26            <IncludeFiles Value="$(ProjOutDir)"/>
     27            <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-${BuildMode}"/>
     28          </SearchPaths>
     29          <Parsing>
     30            <SyntaxOptions>
     31              <CStyleOperator Value="False"/>
     32              <AllowLabel Value="False"/>
     33              <CPPInline Value="False"/>
     34            </SyntaxOptions>
     35          </Parsing>
     36          <CodeGeneration>
     37            <Optimizations>
     38              <OptimizationLevel Value="3"/>
     39            </Optimizations>
     40          </CodeGeneration>
     41          <Linking>
     42            <Debugging>
     43              <GenerateDebugInfo Value="False"/>
     44            </Debugging>
     45            <Options>
     46              <Win32>
     47                <GraphicApplication Value="True"/>
     48              </Win32>
     49            </Options>
     50          </Linking>
     51          <Other>
     52            <CompilerMessages>
     53              <IgnoredMessages idx5024="True"/>
     54            </CompilerMessages>
     55          </Other>
     56        </CompilerOptions>
     57      </Item2>
    1958    </BuildModes>
    2059    <PublishOptions>
    … …  
    64103      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-${BuildMode}"/>
    65104    </SearchPaths>
     105    <Parsing>
     106      <SyntaxOptions>
     107        <CStyleOperator Value="False"/>
     108        <IncludeAssertionCode Value="True"/>
     109        <AllowLabel Value="False"/>
     110        <CPPInline Value="False"/>
     111      </SyntaxOptions>
     112    </Parsing>
     113    <CodeGeneration>
     114      <Checks>
     115        <IOChecks Value="True"/>
     116        <RangeChecks Value="True"/>
     117        <OverflowChecks Value="True"/>
     118        <StackChecks Value="True"/>
     119      </Checks>
     120      <VerifyObjMethodCallValidity Value="True"/>
     121    </CodeGeneration>
    66122    <Linking>
     123      <Debugging>
     124        <UseHeaptrc Value="True"/>
     125      </Debugging>
    67126      <Options>
    68127        <Win32>
    … …  
    71130      </Options>
    72131    </Linking>
     132    <Other>
     133      <CompilerMessages>
     134        <IgnoredMessages idx5024="True"/>
     135      </CompilerMessages>
     136    </Other>
    73137  </CompilerOptions>
    74138  <Debugging>

  • DpiControls/Demo/UDpiFormMain.lfm

    r534 r535  
    55  Height = 0
    66  Visible = True
     7  Enabled = True
     8  ShowHint = False
     9  BorderStyle = Controls
    710  OnCreate = DpiFormMainCreate
    8   object DpiButton1: TDpiButton
    9     Top = 128
    10     Left = 8
    11     Width = 150
    12     Height = 40
     11  object DpiPaintBox1: TDpiPaintBox
     12    Top = 161
     13    Left = 124
     14    Width = 100
     15    Height = 100
    1316    Visible = True
    14     Caption = 'Test'
    15     OnClick = DpiButton1Click
     17    Enabled = True
     18    ShowHint = False
     19    OnPaint = DpiPaintBox1Paint
     20    left = 88
     21    top = 248
    1622  end
    1723end

  • DpiControls/Demo/UDpiFormMain.pas

    r534 r535  
    66
    77uses
    8   Classes, SysUtils, UDpiControls, Dialogs;
     8  Classes, SysUtils, UDpiControls, Dialogs, Graphics;
    99
    1010type
    … …  
    1313
    1414  TDpiFormMain = class(TDpiForm)
    15     DpiButton1: TDpiButton;
     15    DpiPaintBox1: TDpiPaintBox;
    1616    procedure DpiButton1Click(Sender: TObject);
    1717    procedure DpiFormMainCreate(Sender: TObject);
     18    procedure DpiPaintBox1Paint(Sender: TObject);
    1819  private
    19 
    2020  public
    2121
    … …  
    3333procedure TDpiFormMain.DpiFormMainCreate(Sender: TObject);
    3434var
    35   DpiButton: TDpiButton;
    36   DpiImage: TDpiImage;
     35  Button: TDpiButton;
     36  Image: TDpiImage;
     37  ListBox: TDpiListBox;
     38  I: Integer;
     39  PaintBox: TDpiPaintBox;
    3740begin
    38   DpiButton := TDpiButton.Create(DpiFormMain);
    39   DpiButton.Parent := Self;
    40   DpiButton.SetBounds(10, 10, 100, 30);
    41   DpiButton.Caption := 'Click me';
    42   DpiButton.Visible := True;
    43   DpiButton1.Parent := Self;
     41  Button := TDpiButton.Create(DpiFormMain);
     42  Button.Parent := Self;
     43  Button.SetBounds(10, 10, 100, 30);
     44  Button.Caption := 'Click me';
     45  Button.Visible := True;
    4446
    45   DpiImage := TDpiImage.Create(DpiFormMain);
    46   DpiImage.Parent := Self;
    47   DpiImage.SetBounds(150, 10, 100, 100);
    48   DpiImage.Visible := True;
    49   DpiImage.Stretch := True;
    50   DpiImage.VclImage.Picture.LoadFromFile('dance.jpg');
     47  Image := TDpiImage.Create(DpiFormMain);
     48  Image.Parent := Self;
     49  Image.SetBounds(150, 10, 100, 100);
     50  Image.Visible := True;
     51  Image.Stretch := True;
     52  Image.VclImage.Picture.LoadFromFile('dance.jpg');
     53  //Image.Picture.LoadFromFile('dance.jpg');
     54
     55  ListBox := TDpiListBox.Create(DpiFormMain);
     56  for I := 0 to 10 do
     57    ListBox.VclListBox.Items.Add('Item ' + IntToStr(I));
     58  ListBox.Parent := Self;
     59  ListBox.SetBounds(250, 10, 100, 100);
     60  ListBox.Visible := True;
     61
     62  DpiPaintBox1.BoundsRect := Rect(0, 0, 100, 100);
     63  DpiPaintBox1.VclPaintBox.Parent := VclForm;
     64  DpiPaintBox1.Repaint;
     65end;
     66
     67procedure TDpiFormMain.DpiPaintBox1Paint(Sender: TObject);
     68begin
     69  with DpiPaintBox1.Canvas do begin
     70    Brush.Color := clWhite;
     71    Brush.Style := bsSolid;
     72    FillRect(Rect(0, 0, 100, 100));
     73    Caption := IntToStr(Width);
     74    Pen.Color := clGreen;
     75    Pen.Style := psSolid;
     76    MoveTo(0, 0);
     77    LineTo(100, 100);
     78    Font.Color := clRed;
     79    TextOut(40, 10, 'Scaled text');
     80  end;
    5181end;
    5282

  • DpiControls/Demo/UFormMain.lfm

    r534 r535  
    3838    TabOrder = 1
    3939  end
     40  object Timer1: TTimer
     41    Interval = 100
     42    OnTimer = Timer1Timer
     43    left = 256
     44    top = 40
     45  end
    4046end

  • DpiControls/Demo/UFormMain.pas

    r534 r535  
    1616    ButtonNewDpiForm: TButton;
    1717    Label1: TLabel;
     18    Timer1: TTimer;
    1819    TrackBar1: TTrackBar;
    1920    procedure ButtonNewDpiFormClick(Sender: TObject);
    2021    procedure FormShow(Sender: TObject);
     22    procedure Timer1Timer(Sender: TObject);
    2123    procedure TrackBar1Change(Sender: TObject);
    2224  private
    2325
    2426  public
    25 
     27    Redraw: Boolean;
    2628  end;
    2729
    … …  
    4244end;
    4345
     46procedure TFormMain.Timer1Timer(Sender: TObject);
     47begin
     48  Redraw := False;
     49  DpiScreen.Dpi := TrackBar1.Position;
     50end;
     51
    4452procedure TFormMain.ButtonNewDpiFormClick(Sender: TObject);
    4553var
    … …  
    5563procedure TFormMain.TrackBar1Change(Sender: TObject);
    5664begin
    57   DpiScreen.Dpi := TrackBar1.Position;
     65  Redraw := True;
    5866end;
    5967

  • DpiControls/UDpiControls.pas

    r534 r535  
    77uses
    88  Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf,
    9   Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls;
     9  Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType;
    1010
    1111type
    … …  
    2626    FOnChange: TNotifyEvent;
    2727    FSize: Integer;
     28    function GetColor: TColor;
     29    function GetName: string;
     30    function GetPixelsPerInch: Integer;
     31    function GetStyle: TFontStyles;
     32    procedure SetColor(AValue: TColor);
     33    procedure SetName(AValue: string);
    2834    procedure SetOnChange(AValue: TNotifyEvent);
     35    procedure SetPixelsPerInch(AValue: Integer);
    2936    procedure SetSize(AValue: Integer);
    3037    procedure DoChange;
     38    procedure SetStyle(AValue: TFontStyles);
    3139  protected
    3240    procedure ScreenChanged;
    … …  
    3543    constructor Create;
    3644    destructor Destroy; override;
     45    procedure Assign(Source: TDpiFont);
    3746  published
     47    property Color: TColor read GetColor write SetColor;
     48    property Name: string read GetName write SetName;
     49    property Style: TFontStyles read GetStyle write SetStyle;
    3850    property Size: Integer read FSize write SetSize;
     51    property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch;
    3952    property OnChange: TNotifyEvent read FOnChange write SetOnChange;
    4053  end;
    … …  
    5265    FOnResize: TNotifyEvent;
    5366    FTop: Integer;
    54     FVisible: Boolean;
    5567    FWidth: Integer;
    5668    FParent: TDpiWinControl;
     69    function GetBoundsRect: TRect;
     70    function GetClientHeight: Integer;
     71    function GetClientWidth: Integer;
     72    function GetEnabled: Boolean;
     73    function GetOnClick: TNotifyEvent;
     74    function GetShowHint: Boolean;
     75    function GetVisible: Boolean;
     76    procedure SetBoundsRect(AValue: TRect);
     77    procedure SetEnabled(AValue: Boolean);
    5778    procedure SetFont(AValue: TDpiFont);
    5879    procedure SetOnChangeBounds(AValue: TNotifyEvent);
     80    procedure SetOnClick(AValue: TNotifyEvent);
    5981    procedure SetOnResize(AValue: TNotifyEvent);
     82    procedure SetShowHint(AValue: Boolean);
    6083    procedure VclFormResize(Sender: TObject);
    6184    procedure VclChangeBounds(Sender: TObject);
    … …  
    7598    function GetVclControl: TControl; virtual;
    7699    procedure UpdateVclControl; virtual;
     100    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
     101      X, Y: Integer); virtual;
     102    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
     103      X, Y: Integer); virtual;
     104    procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
    77105  public
    78106    procedure ScreenChanged; virtual;
    … …  
    80108    procedure Show;
    81109    procedure Hide;
     110    procedure Invalidate;
     111    procedure Repaint;
    82112    constructor Create(TheOwner: TComponent); override;
    83113    destructor Destroy; override;
    84114    property Parent: TDpiWinControl read FParent write SetParent;
     115    property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
     116    property ClientWidth: Integer read GetClientWidth;
     117    property ClientHeight: Integer read GetClientHeight;
    85118  published
    86119    property Top: Integer read FTop write SetTop;
    … …  
    88121    property Width: Integer read FWidth write SetWidth;
    89122    property Height: Integer read FHeight write SetHeight;
    90     property Visible: Boolean read FVisible write SetVisible;
     123    property Visible: Boolean read GetVisible write SetVisible;
    91124    property Caption: string read GetCaption write SetCaption;
     125    property Enabled: Boolean read GetEnabled write SetEnabled;
     126    property ShowHint: Boolean read GetShowHint write SetShowHint;
    92127    property Font: TDpiFont read FFont write SetFont;
    93128    property OnResize: TNotifyEvent read FOnResize write SetOnResize;
    94129    property OnChangeBounds: TNotifyEvent read FOnChangeBounds write SetOnChangeBounds;
     130    property OnClick: TNotifyEvent read GetOnClick write SetOnClick;
    95131  end;
    96132
    97133  TDpiControls = specialize TFPGObjectList<TDpiControl>;
    98134
     135  { TDpiCanvas }
     136
     137  TDpiCanvas = class
     138  private
     139    FFont: TDpiFont;
     140    function GetBrush: TBrush;
     141    function GetHandle: HDC;
     142    function GetHeight: Integer;
     143    function GetPen: TPen;
     144    function GetPixel(X, Y: Integer): TColor;
     145    function GetWidth: Integer;
     146    procedure SetBrush(AValue: TBrush);
     147    procedure SetFont(AValue: TDpiFont);
     148    procedure SetHandle(AValue: HDC);
     149    procedure SetPen(AValue: TPen);
     150    procedure SetPixel(X, Y: Integer; AValue: TColor);
     151  public
     152    VclCanvas: TCanvas;
     153    procedure FrameRect(Rect: TRect);
     154    function TextWidth(Text: string): Integer;
     155    function TextHeight(Text: string): Integer;
     156    procedure TextOut(X, Y: Integer; Text: string);
     157    procedure MoveTo(X, Y: Integer);
     158    procedure LineTo(X, Y: Integer);
     159    procedure FillRect(ARect: TRect);
     160    procedure FillRect(X1, Y1, X2, Y2: Integer);
     161    constructor Create;
     162    destructor Destroy; override;
     163    property Handle: HDC read GetHandle write SetHandle;
     164    property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
     165    property Width: Integer read GetWidth;
     166    property Height: Integer read GetHeight;
     167  published
     168    property Brush: TBrush read GetBrush write SetBrush;
     169    property Pen: TPen read GetPen write SetPen;
     170    property Font: TDpiFont read FFont write SetFont;
     171  end;
     172
     173  { TDpiGraphicControl }
     174
     175  TDpiGraphicControl = class(TDpiControl)
     176  private
     177    FCanvas: TDpiCanvas;
     178    procedure SetCanvas(AValue: TDpiCanvas);
     179  protected
     180    procedure Paint; virtual;
     181  public
     182    constructor Create(TheOwner: TComponent); override;
     183    destructor Destroy; override;
     184  published
     185    property Canvas: TDpiCanvas read FCanvas write SetCanvas;
     186  end;
     187
    99188  { TDpiWinControl }
    100189
    101190  TDpiWinControl = class(TDpiControl)
    102191  private
     192    function GetHandle: HWND;
     193    procedure SetHandle(AValue: HWND);
    103194  protected
    104195    function GetVclWinControl: TWinControl; virtual;
    … …  
    106197    Controls: TDpiControls;
    107198    procedure ScreenChanged; override;
     199    function ControlCount: Integer;
    108200    constructor Create(TheOwner: TComponent); override;
    109201    destructor Destroy; override;
     202    property Handle: HWND read GetHandle write SetHandle;
    110203  published
    111204  end;
    … …  
    115208  TDpiForm = class(TDpiWinControl)
    116209  private
     210    function GetBorderStyle: TBorderStyle;
     211    function GetCanvas: TDpiCanvas;
    117212    function GetOnCreate: TNotifyEvent;
    118213    function GetOnDestroy: TNotifyEvent;
    119214    function GetOnHide: TNotifyEvent;
    120215    function GetOnShow: TNotifyEvent;
     216    procedure SetBorderStyle(AValue: TBorderStyle);
    121217    procedure SetOnCreate(AValue: TNotifyEvent);
    122218    procedure SetOnDestroy(AValue: TNotifyEvent);
    … …  
    130226  public
    131227    VclForm: TForm;
     228    property Canvas: TDpiCanvas read GetCanvas;
    132229    constructor Create(TheOwner: TComponent); override;
    133230    destructor Destroy; override;
    134231  published
     232    property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle;
    135233    property OnShow: TNotifyEvent read GetOnShow write SetOnShow;
    136234    property OnHide: TNotifyEvent read GetOnHide write SetOnHide;
    … …  
    145243  TDpiButton = class(TDpiControl)
    146244  private
    147     FOnClick: TNotifyEvent;
    148     procedure SetOnClick(AValue: TNotifyEvent);
    149245  protected
    150246    function GetVclControl: TControl; override;
    151247  public
    152248    VclButton: TButton;
    153     constructor Create(TheOwner: TComponent); override;
    154249    destructor Destroy; override;
    155250  published
    156     property OnClick: TNotifyEvent read FOnClick write SetOnClick;
     251  end;
     252
     253  { TDpiListBox }
     254
     255  TDpiListBox = class(TDpiControl)
     256  private
     257  protected
     258    function GetVclControl: TControl; override;
     259  public
     260    VclListBox: TListBox;
     261    destructor Destroy; override;
     262  end;
     263
     264  { TDpiBitmap }
     265
     266  TDpiBitmap = class
     267  private
     268    FCanvas: TDpiCanvas;
     269  published
     270    property Canvas: TDpiCanvas read FCanvas;
     271  end;
     272
     273  { TDpiPicture }
     274
     275  TDpiPicture = class(TPersistent)
     276  private
     277    FBitmap: TDpiBitmap;
     278    procedure SetBitmap(AValue: TDpiBitmap);
     279  published
     280    procedure LoadFromFile(FileName: string);
     281    property Bitmpa: TDpiBitmap read FBitmap write SetBitmap;
    157282  end;
    158283
    … …  
    161286  TDpiImage = class(TDpiControl)
    162287  private
     288    FDpiPicture: TDpiPicture;
    163289    FStretch: Boolean;
     290    procedure SetPicture(AValue: TDpiPicture);
    164291    procedure SetStretch(AValue: Boolean);
    165292  protected
    … …  
    167294    VclImage: TImage;
    168295    function GetVclControl: TControl; override;
     296    destructor Destroy; override;
     297  published
     298    property Stretch: Boolean read FStretch write SetStretch;
     299    property Picture: TDpiPicture read FDpiPicture write SetPicture;
     300  end;
     301
     302  { TDpiPaintBox }
     303
     304  TDpiPaintBox = class(TDpiGraphicControl)
     305  private
     306    function GetOnPaint: TNotifyEvent;
     307    procedure SetOnPaint(AValue: TNotifyEvent);
     308  public
     309    VclPaintBox: TPaintBox;
     310    function GetVclControl: TControl; override;
    169311    constructor Create(TheOwner: TComponent); override;
    170312    destructor Destroy; override;
    171313  published
    172     property Stretch: Boolean read FStretch write SetStretch;
     314    property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
    173315  end;
    174316
    … …  
    210352  DpiFormFileDesc := TDpiFormFileDesc.Create;
    211353  RegisterProjectFileDescriptor(DpiFormFileDesc);
    212   RegisterComponents('DpiControls', [TDpiButton, TDpiImage]);
     354  RegisterComponents('DpiControls', [TDpiButton, TDpiImage, TDpiPaintBox, TDpiListBox]);
    213355end;
    214356
    … …  
    221363begin
    222364  Result := Round(Value * 96 / DpiScreen.Dpi);
     365end;
     366
     367function ScaleRectToVcl(Value: TRect): TRect;
     368begin
     369  Result.Left := ScaleToVcl(Value.Left);
     370  Result.Top := ScaleToVcl(Value.Top);
     371  Result.Right := ScaleToVcl(Value.Right);
     372  Result.Bottom := ScaleToVcl(Value.Bottom);
     373end;
     374
     375function ScaleRectFromVcl(Value: TRect): TRect;
     376begin
     377  Result.Left := ScaleFromVcl(Value.Left);
     378  Result.Top := ScaleFromVcl(Value.Top);
     379  Result.Right := ScaleFromVcl(Value.Right);
     380  Result.Bottom := ScaleFromVcl(Value.Bottom);
     381end;
     382
     383{ TDpiListBox }
     384
     385function TDpiListBox.GetVclControl: TControl;
     386begin
     387  if not Assigned(VclListBox) then VclListBox := TListBox.Create(nil);
     388  Result := VclListBox;
     389end;
     390
     391destructor TDpiListBox.Destroy;
     392begin
     393  FreeAndNil(VclListBox);
     394  inherited Destroy;
     395end;
     396
     397{ TDpiPaintBox }
     398
     399function TDpiPaintBox.GetOnPaint: TNotifyEvent;
     400begin
     401  Result := VclPaintBox.OnPaint;
     402end;
     403
     404procedure TDpiPaintBox.SetOnPaint(AValue: TNotifyEvent);
     405begin
     406  VclPaintBox.OnPaint := AValue;
     407end;
     408
     409function TDpiPaintBox.GetVclControl: TControl;
     410begin
     411  if not Assigned(VclPaintBox) then VclPaintBox := TPaintBox.Create(nil);
     412  Result := VclPaintBox;
     413end;
     414
     415constructor TDpiPaintBox.Create(TheOwner: TComponent);
     416begin
     417  inherited;
     418  Canvas := TDpiCanvas.Create;
     419  Canvas.VclCanvas := VclPaintBox.Canvas;
     420  Canvas.Font.VclFont := VclPaintBox.Canvas.Font;
     421  UpdateVclControl;
     422  ScreenChanged;
     423end;
     424
     425destructor TDpiPaintBox.Destroy;
     426begin
     427  FreeAndNil(VclPaintBox);
     428  inherited;
     429end;
     430
     431{ TDpiPicture }
     432
     433procedure TDpiPicture.SetBitmap(AValue: TDpiBitmap);
     434begin
     435  if FBitmap = AValue then Exit;
     436  FBitmap := AValue;
     437end;
     438
     439procedure TDpiPicture.LoadFromFile(FileName: string);
     440begin
     441end;
     442
     443
     444{ TDpiCanvas }
     445
     446function TDpiCanvas.GetBrush: TBrush;
     447begin
     448  Result := VclCanvas.Brush;
     449end;
     450
     451function TDpiCanvas.GetHandle: HDC;
     452begin
     453  Result := VclCanvas.Handle;
     454end;
     455
     456function TDpiCanvas.GetHeight: Integer;
     457begin
     458  Result := ScaleFromVcl(VclCanvas.Height);
     459end;
     460
     461function TDpiCanvas.GetPen: TPen;
     462begin
     463  Result := VclCanvas.Pen;
     464end;
     465
     466function TDpiCanvas.GetPixel(X, Y: Integer): TColor;
     467begin
     468  Result := VclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)];
     469end;
     470
     471function TDpiCanvas.GetWidth: Integer;
     472begin
     473  Result := ScaleFromVcl(VclCanvas.Width);
     474end;
     475
     476procedure TDpiCanvas.SetBrush(AValue: TBrush);
     477begin
     478  VclCanvas.Brush := AValue;
     479end;
     480
     481procedure TDpiCanvas.SetFont(AValue: TDpiFont);
     482begin
     483  if FFont = AValue then Exit;
     484  FFont := AValue;
     485end;
     486
     487procedure TDpiCanvas.SetHandle(AValue: HDC);
     488begin
     489  VclCanvas.Handle := AValue;
     490end;
     491
     492procedure TDpiCanvas.SetPen(AValue: TPen);
     493begin
     494  VclCanvas.Pen := AValue;
     495end;
     496
     497procedure TDpiCanvas.SetPixel(X, Y: Integer; AValue: TColor);
     498begin
     499  VclCanvas.Pixels[ScaleToVcl(X), ScaleToVcl(Y)] := AValue;
     500end;
     501
     502procedure TDpiCanvas.FrameRect(Rect: TRect);
     503begin
     504  VclCanvas.FrameRect(ScaleRectToVcl(Rect));
     505end;
     506
     507function TDpiCanvas.TextWidth(Text: string): Integer;
     508begin
     509  Result := ScaleFromVcl(VclCanvas.TextWidth(Text));
     510end;
     511
     512function TDpiCanvas.TextHeight(Text: string): Integer;
     513begin
     514  Result := ScaleFromVcl(VclCanvas.TextHeight(Text));
     515end;
     516
     517procedure TDpiCanvas.TextOut(X, Y: Integer; Text: string);
     518begin
     519  VclCanvas.TextOut(ScaleToVcl(X), ScaleToVcl(Y), Text);
     520end;
     521
     522procedure TDpiCanvas.MoveTo(X, Y: Integer);
     523begin
     524  VclCanvas.MoveTo(ScaleToVcl(X), ScaleToVcl(Y));
     525end;
     526
     527procedure TDpiCanvas.LineTo(X, Y: Integer);
     528begin
     529  VclCanvas.LineTo(ScaleToVcl(X), ScaleToVcl(Y));
     530end;
     531
     532procedure TDpiCanvas.FillRect(ARect: TRect);
     533begin
     534  VclCanvas.FillRect(ScaleRectToVcl(ARect));
     535end;
     536
     537procedure TDpiCanvas.FillRect(X1, Y1, X2, Y2: Integer);
     538begin
     539  VclCanvas.FillRect(ScaleToVcl(X1), ScaleToVcl(Y1), ScaleToVcl(X2), ScaleToVcl(Y2));
     540end;
     541
     542constructor TDpiCanvas.Create;
     543begin
     544  FFont := TDpiFont.Create;
     545end;
     546
     547destructor TDpiCanvas.Destroy;
     548begin
     549  FreeAndNil(FFont);
     550  inherited;
     551end;
     552
     553{ TDpiGraphicControl }
     554
     555procedure TDpiGraphicControl.SetCanvas(AValue: TDpiCanvas);
     556begin
     557  if FCanvas = AValue then Exit;
     558  FCanvas := AValue;
     559end;
     560
     561procedure TDpiGraphicControl.Paint;
     562begin
     563end;
     564
     565constructor TDpiGraphicControl.Create(TheOwner: TComponent);
     566begin
     567  inherited;
     568  FCanvas := TDpiCanvas.Create;
     569end;
     570
     571destructor TDpiGraphicControl.Destroy;
     572begin
     573  FreeAndNil(FCanvas);
     574  inherited;
    223575end;
    224576
    … …  
    233585end;
    234586
     587procedure TDpiImage.SetPicture(AValue: TDpiPicture);
     588begin
     589  if FDpiPicture = AValue then Exit;
     590  FDpiPicture := AValue;
     591end;
     592
    235593function TDpiImage.GetVclControl: TControl;
    236594begin
     595  if not Assigned(VclImage) then VclImage := TImage.Create(nil);
    237596  Result := VclImage;
    238 end;
    239 
    240 constructor TDpiImage.Create(TheOwner: TComponent);
    241 begin
    242   inherited;
    243   VclImage := TImage.Create(nil);
    244597end;
    245598
    … …  
    264617end;
    265618
     619procedure TDpiFont.SetStyle(AValue: TFontStyles);
     620begin
     621  VclFont.Style := AValue;
     622end;
     623
    266624procedure TDpiFont.ScreenChanged;
    267625begin
    … …  
    275633end;
    276634
     635procedure TDpiFont.SetPixelsPerInch(AValue: Integer);
     636begin
     637  VclFont.PixelsPerInch := PixelsPerInch;
     638end;
     639
     640function TDpiFont.GetName: string;
     641begin
     642  Result := VclFont.Name;
     643end;
     644
     645function TDpiFont.GetColor: TColor;
     646begin
     647  Result := VclFont.Color;
     648end;
     649
     650function TDpiFont.GetPixelsPerInch: Integer;
     651begin
     652  Result := VclFont.PixelsPerInch;
     653end;
     654
     655function TDpiFont.GetStyle: TFontStyles;
     656begin
     657  Result := VclFont.Style;
     658end;
     659
     660procedure TDpiFont.SetColor(AValue: TColor);
     661begin
     662  VclFont.Color := AValue;
     663end;
     664
     665procedure TDpiFont.SetName(AValue: string);
     666begin
     667  VclFont.Name := AValue;
     668end;
     669
    277670constructor TDpiFont.Create;
    278671begin
    279   VclFont := TFont.Create;
    280672  Size := 8;
    281673end;
    … …  
    283675destructor TDpiFont.Destroy;
    284676begin
    285   FreeAndNil(VclFont);
    286677  inherited Destroy;
    287678end;
    288679
     680procedure TDpiFont.Assign(Source: TDpiFont);
     681begin
     682  VclFont.Assign(Source.VclFont);
     683  Size := Source.Size;
     684  FOnChange := Source.FOnChange;
     685end;
     686
    289687{ TDpiWinControl }
     688
     689function TDpiWinControl.GetHandle: HWND;
     690begin
     691  Result := GetVclWinControl.Handle;
     692end;
     693
     694procedure TDpiWinControl.SetHandle(AValue: HWND);
     695begin
     696  GetVclWinControl.Handle := AValue;
     697end;
    290698
    291699function TDpiWinControl.GetVclWinControl: TWinControl;
    … …  
    303711end;
    304712
     713function TDpiWinControl.ControlCount: Integer;
     714begin
     715  Result := Controls.Count;
     716end;
     717
    305718constructor TDpiWinControl.Create(TheOwner: TComponent);
    306719begin
    307   inherited;
    308720  Controls := TDpiControls.Create;
    309721  Controls.FreeObjects := False;
     722  inherited;
    310723end;
    311724
    … …  
    361774{ TDpiButton }
    362775
    363 procedure TDpiButton.SetOnClick(AValue: TNotifyEvent);
    364 begin
    365   if FOnClick = AValue then Exit;
    366   FOnClick := AValue;
    367   VclButton.OnClick := AValue;
    368 end;
    369 
    370776function TDpiButton.GetVclControl: TControl;
    371777begin
     778  if not Assigned(VclButton) then VclButton := TButton.Create(nil);
    372779  Result := VclButton;
    373 end;
    374 
    375 constructor TDpiButton.Create(TheOwner: TComponent);
    376 begin
    377   inherited;
    378   VclButton := TButton.Create(nil);
    379   ScreenChanged;
    380780end;
    381781
    … …  
    397797procedure TDpiControl.SetVisible(AValue: Boolean);
    398798begin
    399   if FVisible = AValue then Exit;
    400   FVisible := AValue;
    401799  GetVclControl.Visible := AValue;
    402800end;
    … …  
    418816  GetVclControl.OnResize := @VclFormResize;
    419817  GetVclControl.OnChangeBounds := @VclChangeBounds;
     818end;
     819
     820procedure TDpiControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
     821  Y: Integer);
     822begin
     823  // TODO
     824end;
     825
     826procedure TDpiControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
     827  Y: Integer);
     828begin
     829  // TODO
     830end;
     831
     832procedure TDpiControl.MouseMove(Shift: TShiftState; X, Y: Integer);
     833begin
     834  // TODO
    420835end;
    421836
    … …  
    445860end;
    446861
     862procedure TDpiControl.Invalidate;
     863begin
     864  GetVclControl.Invalidate;
     865end;
     866
     867procedure TDpiControl.Repaint;
     868begin
     869  GetVclControl.Repaint;
     870end;
     871
    447872constructor TDpiControl.Create(TheOwner: TComponent);
    448873begin
    … …  
    450875  FFont := TDpiFont.Create;
    451876  FFont.OnChange := @FontChanged;
     877  if Assigned(TheOwner) and (TheOwner is TDpiWinControl) then
     878    Parent := TDpiWinControl(TheOwner);
     879  GetVclControl;
     880  UpdateVclControl;
     881  ScreenChanged;
    452882end;
    453883
    … …  
    492922end;
    493923
     924function TDpiControl.GetBoundsRect: TRect;
     925begin
     926  Result.Left := Left;
     927  Result.Top := Top;
     928  Result.Right := Left + Width;
     929  Result.Bottom := Top + Height;
     930end;
     931
     932function TDpiControl.GetClientHeight: Integer;
     933begin
     934  Result := ScaleFromVcl(GetVclControl.ClientHeight);
     935end;
     936
     937function TDpiControl.GetClientWidth: Integer;
     938begin
     939  Result := ScaleFromVcl(GetVclControl.ClientWidth);
     940end;
     941
     942function TDpiControl.GetEnabled: Boolean;
     943begin
     944  Result := GetVclControl.Enabled;
     945end;
     946
     947function TDpiControl.GetOnClick: TNotifyEvent;
     948begin
     949  Result := GetVclControl.OnClick;
     950end;
     951
     952function TDpiControl.GetShowHint: Boolean;
     953begin
     954  Result := GetVclControl.ShowHint;
     955end;
     956
     957function TDpiControl.GetVisible: Boolean;
     958begin
     959  Result := GetVclControl.Visible;
     960end;
     961
     962procedure TDpiControl.SetBoundsRect(AValue: TRect);
     963begin
     964  SetBounds(AValue.Left, AValue.Top, AValue.Right - AValue.Left, AValue.Bottom - AValue.Top);
     965end;
     966
     967procedure TDpiControl.SetEnabled(AValue: Boolean);
     968begin
     969  GetVclControl.Enabled := AValue;
     970end;
     971
    494972procedure TDpiControl.SetOnChangeBounds(AValue: TNotifyEvent);
    495973begin
    … …  
    498976end;
    499977
     978procedure TDpiControl.SetOnClick(AValue: TNotifyEvent);
     979begin
     980  GetVclControl.OnClick := AValue;
     981end;
     982
    500983procedure TDpiControl.SetOnResize(AValue: TNotifyEvent);
    501984begin
    … …  
    504987end;
    505988
     989procedure TDpiControl.SetShowHint(AValue: Boolean);
     990begin
     991  GetVclControl.ShowHint := AValue;
     992end;
     993
    506994procedure TDpiControl.VclFormResize(Sender: TObject);
    507995begin
    508   SetBounds(ScaleFromVcl(GetVclControl.Left), ScaleFromVcl(GetVclControl.Top),
    509     ScaleFromVcl(GetVclControl.Width), ScaleFromVcl(GetVclControl.Height));
     996  BoundsRect := ScaleRectFromVcl(GetVclControl.BoundsRect);
    510997  DoFormResize;
    511998end;
    … …  
    5131000procedure TDpiControl.VclChangeBounds(Sender: TObject);
    5141001begin
    515   SetBounds(ScaleFromVcl(GetVclControl.Left), ScaleFromVcl(GetVclControl.Top),
    516     ScaleFromVcl(GetVclControl.Width), ScaleFromVcl(GetVclControl.Height));
     1002  BoundsRect := ScaleRectFromVcl(GetVclControl.BoundsRect);
    5171003  DoChangeBounds;
    5181004end;
    … …  
    5401026procedure TDpiControl.UpdateBounds;
    5411027begin
    542   GetVclControl.SetBounds(ScaleToVcl(Left), ScaleToVcl(Top), ScaleToVcl(Width), ScaleToVcl(Height));
     1028  GetVclControl.BoundsRect := ScaleRectToVcl(BoundsRect);
    5431029end;
    5441030
    … …  
    5781064{ TDpiForm }
    5791065
     1066function TDpiForm.GetBorderStyle: TBorderStyle;
     1067begin
     1068  Result := VclForm.BorderStyle;
     1069end;
     1070
     1071function TDpiForm.GetCanvas: TDpiCanvas;
     1072begin
     1073  Result := Canvas;
     1074end;
     1075
    5801076function TDpiForm.GetOnCreate: TNotifyEvent;
    5811077begin
    … …  
    5961092begin
    5971093  Result := VclForm.OnShow;
     1094end;
     1095
     1096procedure TDpiForm.SetBorderStyle(AValue: TBorderStyle);
     1097begin
     1098  VclForm.BorderStyle := AValue;
    5981099end;
    5991100
    … …  
    6421143function TDpiForm.GetVclControl: TControl;
    6431144begin
    644   Result := VclForm;
     1145  Result := GetVclWinControl;
    6451146end;
    6461147
    6471148function TDpiForm.GetVclWinControl: TWinControl;
    6481149begin
     1150  if not Assigned(VclForm) then VclForm := TForm.Create(nil);
    6491151  Result := VclForm;
    6501152end;
    … …  
    6541156begin
    6551157  inherited;
    656   VclForm := TForm.Create(nil);
    657   ScreenChanged;
    6581158  DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);
    6591159  GlobalNameSpace.BeginWrite;
    … …  
    6681168    GlobalNameSpace.EndWrite;
    6691169  end;
     1170  ScreenChanged;
    6701171  UpdateVclControl;
    6711172  DoOnCreate;
Note: See TracChangeset for help on using the changeset viewer.