Ignore:
Timestamp:
Jun 23, 2019, 12:36:19 AM (5 years ago)
Author:
chronos
Message:
File:
1 edited

Legend:

Unmodified
Added
Removed
  • DpiControls/UDpiControls.pas

    r536 r537  
    88  Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf,
    99  Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType, GraphType,
    10   Types;
     10  Types, CustApp, LMessages, LCLIntf;
    1111
    1212type
    13    { TDpiFormFileDesc }
     13  TMessageEvent = procedure (var TheMessage : TLMessage) of object;
     14
     15  { TFormEx }
     16
     17  TFormEx = class(TForm)
     18  private
     19    FOnMessage: TMessageEvent;
     20  protected
     21    procedure WndProc(var TheMessage : TLMessage); override;
     22    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
     23  end;
     24
     25  { TGraphicControlEx }
     26
     27  TGraphicControlEx = class(TGraphicControl)
     28  public
     29    property OnPaint;
     30    property OnMouseDown;
     31    property OnMouseUp;
     32    property OnMouseMove;
     33    procedure Paint; override;
     34  end;
     35
     36  { TDpiFormFileDesc }
    1437
    1538  TDpiFormFileDesc = class(TFileDescPascalUnitWithResource)
     
    2346  { TDpiFont }
    2447
    25   TDpiFont = class
     48  TDpiFont = class(TPersistent)
    2649  private
    2750    FOnChange: TNotifyEvent;
    2851    FSize: Integer;
     52    function GetCharSet: TFontCharSet;
    2953    function GetColor: TColor;
     54    function GetHeight: Integer;
    3055    function GetName: string;
    3156    function GetPixelsPerInch: Integer;
    3257    function GetStyle: TFontStyles;
     58    function IsNameStored: Boolean;
     59    procedure SetCharSet(AValue: TFontCharSet);
    3360    procedure SetColor(AValue: TColor);
     61    procedure SetHeight(AValue: Integer);
    3462    procedure SetName(AValue: string);
    3563    procedure SetOnChange(AValue: TNotifyEvent);
     
    4573    constructor Create;
    4674    destructor Destroy; override;
    47     procedure Assign(Source: TDpiFont);
     75    procedure Assign(Source: TPersistent); override;
    4876  published
     77    property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET;
    4978    property Color: TColor read GetColor write SetColor;
    50     property Name: string read GetName write SetName;
    51     property Style: TFontStyles read GetStyle write SetStyle;
    52     property Size: Integer read FSize write SetSize;
     79    property Name: string read GetName write SetName stored IsNameStored;
     80    property Style: TFontStyles read GetStyle write SetStyle default [];
     81    property Size: Integer read FSize write SetSize stored false;
    5382    property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch;
     83    property Height: Integer read GetHeight write SetHeight default 0;
    5484    property OnChange: TNotifyEvent read FOnChange write SetOnChange;
    5585  end;
     86
     87  { TDpiSizeConstraints }
     88
     89  TDpiSizeConstraints = class(TPersistent)
     90  private
     91    FMaxHeight: TConstraintSize;
     92    FMaxWidth: TConstraintSize;
     93    FMinHeight: TConstraintSize;
     94    FMinWidth: TConstraintSize;
     95    procedure SetMaxHeight(AValue: TConstraintSize);
     96    procedure SetMaxWidth(AValue: TConstraintSize);
     97    procedure SetMinHeight(AValue: TConstraintSize);
     98    procedure SetMinWidth(AValue: TConstraintSize);
     99  published
     100    property MaxHeight: TConstraintSize read FMaxHeight write SetMaxHeight default 0;
     101    property MaxWidth: TConstraintSize read FMaxWidth write SetMaxWidth default 0;
     102    property MinHeight: TConstraintSize read FMinHeight write SetMinHeight default 0;
     103    property MinWidth: TConstraintSize read FMinWidth write SetMinWidth default 0;
     104  end;
     105
    56106
    57107  TDpiWinControl = class;
     
    61111  TDpiControl = class(TComponent)
    62112  private
     113    FConstraints: TDpiSizeConstraints;
    63114    FFont: TDpiFont;
    64115    FHeight: Integer;
    65116    FLeft: Integer;
    66117    FOnChangeBounds: TNotifyEvent;
     118    FOnMouseDown: TMouseEvent;
     119    FOnMouseMove: TMouseMoveEvent;
     120    FOnMouseUp: TMouseEvent;
     121    FOnMouseWheel: TMouseWheelEvent;
    67122    FOnResize: TNotifyEvent;
    68123    FTop: Integer;
     
    73128    function GetClientHeight: Integer;
    74129    function GetClientWidth: Integer;
     130    function GetColor: TColor;
     131    function GetCursor: TCursor;
    75132    function GetEnabled: Boolean;
    76133    function GetHint: string;
     
    82139    procedure SetClientHeight(AValue: Integer);
    83140    procedure SetClientWidth(AValue: Integer);
     141    procedure SetColor(AValue: TColor);
     142    procedure SetCursor(AValue: TCursor);
    84143    procedure SetEnabled(AValue: Boolean);
    85144    procedure SetFont(AValue: TDpiFont);
     
    106165    function GetVclControl: TControl; virtual;
    107166    procedure UpdateVclControl; virtual;
     167    procedure MouseDownHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
     168      X, Y: Integer); virtual;
     169    procedure MouseUpHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
     170      X, Y: Integer); virtual;
     171    procedure MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;
     172    procedure MouseWheelHandler(Sender: TObject; Shift: TShiftState;
     173         WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual;
    108174    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
    109175      X, Y: Integer); virtual;
     
    123189    property Parent: TDpiWinControl read FParent write SetParent;
    124190    property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
     191  published
     192    property ClientHeight: Integer read GetClientHeight write SetClientHeight;
    125193    property ClientWidth: Integer read GetClientWidth write SetClientWidth;
    126     property ClientHeight: Integer read GetClientHeight write SetClientHeight;
    127   published
    128194    property Hint: string read GetHint write SetHint;
    129195    property Top: Integer read FTop write SetTop;
     
    137203    property Font: TDpiFont read FFont write SetFont;
    138204    property Align: TAlign read GetAlign write SetAlign;
     205    property Color: TColor read GetColor write SetColor;
     206    property Constraints: TDpiSizeConstraints read FConstraints write FConstraints;
     207    property Cursor: TCursor read GetCursor write SetCursor default crDefault;
    139208    property OnResize: TNotifyEvent read FOnResize write SetOnResize;
    140209    property OnChangeBounds: TNotifyEvent read FOnChangeBounds write SetOnChangeBounds;
    141210    property OnClick: TNotifyEvent read GetOnClick write SetOnClick;
     211    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
     212    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
     213    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
     214    property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel;
    142215  end;
    143216
     
    214287  TDpiGraphicControl = class(TDpiControl)
    215288  private
     289    FOnPaint: TNotifyEvent;
     290    VclGraphicControl: TGraphicControl;
    216291    FCanvas: TDpiCanvas;
    217     function GetOnPaint: TNotifyEvent;
    218292    procedure SetCanvas(AValue: TDpiCanvas);
    219     procedure SetOnPaint(AValue: TNotifyEvent);
     293    procedure PaintHandler(Sender: TObject);
    220294  protected
    221295    procedure Paint; virtual;
    222296    function GetVclControl: TControl; override;
    223297    function GetVclGraphicControl: TGraphicControl; virtual;
     298    procedure UpdateVclControl; override;
     299    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    224300  public
    225301    constructor Create(TheOwner: TComponent); override;
     
    227303  published
    228304    property Canvas: TDpiCanvas read FCanvas write SetCanvas;
    229     property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
    230305  end;
    231306
     
    262337  TDpiCustomControl = class(TDpiWinControl)
    263338  private
     339    FCanvas: TDpiCanvas;
     340    function GetCanvas: TDpiCanvas;
    264341    function GetOnPaint: TNotifyEvent;
     342    function GetPixelsPerInch: Integer;
    265343    procedure SetOnPaint(AValue: TNotifyEvent);
     344    procedure SetPixelsPerInch(AValue: Integer);
    266345  protected
    267346    function GetVclWinControl: TWinControl; override;
    268347    function GetVclCustomControl: TCustomControl; virtual;
     348  public
     349    property Canvas: TDpiCanvas read GetCanvas;
    269350  published
     351    property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch stored False;
    270352    property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
    271353  end;
    272354
     355  { TDpiControlScrollBar }
     356
     357  TDpiControlScrollBar = class(TPersistent)
     358  private
     359    function GetVisible: Boolean;
     360    procedure SetVisible(AValue: Boolean);
     361  published
     362    property Visible: Boolean read GetVisible write SetVisible;
     363  end;
     364
     365  { TDpiScrollingWinControl }
     366
     367  TDpiScrollingWinControl = class(TDpiCustomControl)
     368  private
     369    FHorzScrollBar: TDpiControlScrollBar;
     370    FVertScrollBar: TDpiControlScrollBar;
     371  protected
     372    function GetVclCustomControl: TCustomControl; override;
     373    function GetVclScrollingWinControl: TScrollingWinControl; virtual;
     374  public
     375    constructor Create(TheOwner: TComponent); override;
     376    destructor Destroy; override;
     377  published
     378    property HorzScrollBar: TDpiControlScrollBar read FHorzScrollBar write FHorzScrollBar;
     379    property VertScrollBar: TDpiControlScrollBar read FVertScrollBar write FVertScrollBar;
     380  end;
     381
    273382  { TDpiForm }
    274383
    275   TDpiForm = class(TDpiCustomControl)
     384  TDpiForm = class(TDpiScrollingWinControl)
    276385  private
     386    FOnActivate: TNotifyEvent;
     387    FOnDeactivate: TNotifyEvent;
    277388    function GetBorderIcons: TBorderIcons;
    278389    function GetBorderStyle: TBorderStyle;
    279     function GetCanvas: TDpiCanvas;
     390    function GetDesignTimePPI: Integer;
    280391    function GetFormState: TFormState;
     392    function GetFormStyle: TFormStyle;
     393    function GetKeyPreview: Boolean;
     394    function GetLCLVersion: string;
    281395    function GetModalResult: TModalResult;
    282396    function GetOnClose: TCloseEvent;
     397    function GetOnCloseQuery: TCloseQueryEvent;
    283398    function GetOnCreate: TNotifyEvent;
    284399    function GetOnDeactivate: TNotifyEvent;
     
    286401    function GetOnHide: TNotifyEvent;
    287402    function GetOnShow: TNotifyEvent;
     403    function GetPosition: TPosition;
     404    function GetWindowState: TWindowState;
    288405    procedure SetBorderIcons(AValue: TBorderIcons);
    289406    procedure SetBorderStyle(AValue: TBorderStyle);
     407    procedure SetDesignTimePPI(AValue: Integer);
     408    procedure SetFormStyle(AValue: TFormStyle);
     409    procedure SetKeyPreview(AValue: Boolean);
     410    procedure SetLCLVersion(AValue: string);
    290411    procedure SetModalResult(AValue: TModalResult);
    291412    procedure SetOnClose(AValue: TCloseEvent);
     413    procedure SetOnCloseQuery(AValue: TCloseQueryEvent);
    292414    procedure SetOnCreate(AValue: TNotifyEvent);
    293415    procedure SetOnDeactivate(AValue: TNotifyEvent);
     
    296418    procedure SetOnShow(AValue: TNotifyEvent);
    297419    procedure DoOnCreate;
     420    procedure FormMessageHandler(var TheMessage: TLMessage);
     421    procedure SetPosition(AValue: TPosition);
     422    procedure SetWindowState(AValue: TWindowState);
     423    procedure ActivateHandler(Sender: TObject);
     424    procedure DeactivateHandler(Sender: TObject);
    298425  protected
    299426    procedure CreateParams(var p: TCreateParams); virtual;
    300427    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    301     function GetVclCustomControl: TCustomControl; override;
     428    function GetVclScrollingWinControl: TScrollingWinControl; override;
    302429    function GetVclForm: TForm; virtual;
     430    procedure UpdateVclControl; override;
    303431  public
    304432    VclForm: TForm;
    305     property Canvas: TDpiCanvas read GetCanvas;
    306433    property ModalResult: TModalResult read GetModalResult write SetModalResult;
    307434    function ShowModal: Integer; virtual;
     
    311438    destructor Destroy; override;
    312439  published
     440    property DesignTimePPI: Integer read GetDesignTimePPI write SetDesignTimePPI; // Not used
    313441    property FormState: TFormState read GetFormState;
     442    property FormStyle: TFormStyle read GetFormStyle write SetFormStyle;
    314443    property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle;
    315444    property BorderIcons: TBorderIcons read GetBorderIcons write SetBorderIcons;
     445    property LCLVersion: string read GetLCLVersion write SetLCLVersion;
     446    property KeyPreview: Boolean read GetKeyPreview write SetKeyPreview default False;
     447    property Position: TPosition read GetPosition write SetPosition default poDesigned;
     448    property WindowState: TWindowState read GetWindowState write SetWindowState default wsNormal;
    316449    property OnShow: TNotifyEvent read GetOnShow write SetOnShow;
    317450    property OnHide: TNotifyEvent read GetOnHide write SetOnHide;
    318451    property OnCreate: TNotifyEvent read GetOnCreate write SetOnCreate;
    319452    property OnDestroy: TNotifyEvent read GetOnDestroy write SetOnDestroy;
    320     property OnDeactivate: TNotifyEvent read GetOnDeactivate write SetOnDeactivate;
     453    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
     454    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
    321455    property OnClose: TCloseEvent read GetOnClose write SetOnClose;
     456    property OnCloseQuery: TCloseQueryEvent read GetOnCloseQuery write SetOnCloseQuery;
     457    property ClientHeight;
     458    property ClientWidth;
     459    property OnMouseUp;
     460    property OnMouseDown;
     461    property OnMouseMove;
    322462  end;
    323463
     
    403543    constructor Create;
    404544    destructor Destroy; override;
     545    procedure Assign(Source: TPersistent); override;
    405546    property ScanLine[Row: Integer]: Pointer read GetScanLine;
    406547  published
     
    448589  public
    449590    VclPaintBox: TPaintBox;
    450     function GetVclControl: TControl; override;
     591    function GetVclGraphicControl: TGraphicControl; override;
    451592    constructor Create(TheOwner: TComponent); override;
    452593    destructor Destroy; override;
     
    464605    function GetHeight: Integer;
    465606    function GetWidth: Integer;
     607    procedure SetActiveForm(AValue: TDpiForm);
    466608    procedure SetDpi(AValue: Integer);
    467609    procedure UpdateForms;
     
    471613    destructor Destroy; override;
    472614    property FormCount: Integer read GetFormCount;
    473     property ActiveForm: TDpiForm read GetActiveForm;
     615    property ActiveForm: TDpiForm read GetActiveForm write SetActiveForm;
    474616  published
    475617    property Dpi: Integer read FDpi write SetDpi;
     
    498640  end;
    499641
     642  { TDpiApplication }
     643
     644  TDpiApplication = class(TComponent)
     645  private
     646    FMainForm: TDpiForm;
     647    FCreatingForm: TDpiForm;
     648    function GetShowMainForm: Boolean;
     649    function GetTitle: string;
     650    procedure SetMainForm(AValue: TDpiForm);
     651    function GetMainForm: TDpiForm;
     652    procedure SetShowMainForm(AValue: Boolean);
     653    procedure SetTitle(AValue: string);
     654  protected
     655    function GetVclApplication: TApplication; virtual;
     656  public
     657    procedure Run;
     658    procedure Initialize;
     659    procedure ProcessMessages;
     660    procedure UpdateMainForm(AForm: TDpiForm);
     661    procedure CreateForm(InstanceClass: TComponentClass; out Reference);
     662    property MainForm: TDpiForm read GetMainForm write SetMainForm;
     663    property ShowMainForm: Boolean read GetShowMainForm write SetShowMainForm default True;
     664    property Title: string read GetTitle write SetTitle;
     665  end;
     666
    500667var
    501668  DpiFormFileDesc: TDpiFormFileDesc;
    502669  DpiScreen: TDpiScreen;
     670  DpiApplication: TDpiApplication;
    503671
    504672procedure Register;
     673function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
    505674
    506675
     
    529698end;
    530699
     700function ScalePointToVcl(Value: TPoint): TPoint;
     701begin
     702  Result.X := ScaleToVcl(Value.X);
     703  Result.Y := ScaleToVcl(Value.Y);
     704end;
     705
     706function ScalePointFromVcl(Value: TPoint): TPoint;
     707begin
     708  Result.X := ScaleFromVcl(Value.X);
     709  Result.Y := ScaleFromVcl(Value.Y);
     710end;
     711
    531712function ScaleRectToVcl(Value: TRect): TRect;
    532713begin
     
    545726end;
    546727
     728function DpiBitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
     729  YSrc: Integer; Rop: DWORD): Boolean;
     730begin
     731  Result := BitBlt(DestDC, ScaleToVcl(X), ScaleToVcl(Y), ScaleToVcl(Width),
     732    ScaleToVcl(Height), SrcDC, ScaleToVcl(XSrc), ScaleToVcl(YSrc), Rop);
     733end;
     734
     735{ TDpiSizeConstraints }
     736
     737procedure TDpiSizeConstraints.SetMaxHeight(AValue: TConstraintSize);
     738begin
     739  if FMaxHeight=AValue then Exit;
     740  FMaxHeight:=AValue;
     741end;
     742
     743procedure TDpiSizeConstraints.SetMaxWidth(AValue: TConstraintSize);
     744begin
     745  if FMaxWidth=AValue then Exit;
     746  FMaxWidth:=AValue;
     747end;
     748
     749procedure TDpiSizeConstraints.SetMinHeight(AValue: TConstraintSize);
     750begin
     751  if FMinHeight=AValue then Exit;
     752  FMinHeight:=AValue;
     753end;
     754
     755procedure TDpiSizeConstraints.SetMinWidth(AValue: TConstraintSize);
     756begin
     757  if FMinWidth=AValue then Exit;
     758  FMinWidth:=AValue;
     759end;
     760
     761{ TDpiScrollingWinControl }
     762
     763function TDpiScrollingWinControl.GetVclCustomControl: TCustomControl;
     764begin
     765  Result := GetVclScrollingWinControl;
     766end;
     767
     768function TDpiScrollingWinControl.GetVclScrollingWinControl: TScrollingWinControl;
     769begin
     770  Result := nil;
     771end;
     772
     773constructor TDpiScrollingWinControl.Create(TheOwner: TComponent);
     774begin
     775  inherited;
     776  FHorzScrollBar := TDpiControlScrollBar.Create;
     777  FVertScrollBar := TDpiControlScrollBar.Create;
     778end;
     779
     780destructor TDpiScrollingWinControl.Destroy;
     781begin
     782  FreeAndNil(FHorzScrollBar);
     783  FreeAndNil(FVertScrollBar);
     784  inherited Destroy;
     785end;
     786
     787{ TDpiControlScrollBar }
     788
     789function TDpiControlScrollBar.GetVisible: Boolean;
     790begin
     791
     792end;
     793
     794procedure TDpiControlScrollBar.SetVisible(AValue: Boolean);
     795begin
     796
     797end;
     798
     799{ TGraphicControlEx }
     800
     801procedure TGraphicControlEx.Paint;
     802begin
     803  inherited Paint;
     804end;
     805
     806{ TFormEx }
     807
     808procedure TFormEx.WndProc(var TheMessage: TLMessage);
     809begin
     810  inherited WndProc(TheMessage);
     811  if Assigned(FOnMessage) then
     812    FOnMessage(TheMessage);
     813end;
     814
     815{ TDpiApplication }
     816
     817procedure TDpiApplication.SetMainForm(AValue: TDpiForm);
     818begin
     819  FMainForm := AValue;
     820end;
     821
     822function TDpiApplication.GetTitle: string;
     823begin
     824  Result := GetVclApplication.Title;
     825end;
     826
     827function TDpiApplication.GetShowMainForm: Boolean;
     828begin
     829  Result := GetVclApplication.ShowMainForm;
     830end;
     831
     832function TDpiApplication.GetMainForm: TDpiForm;
     833begin
     834  Result := FMainForm;
     835end;
     836
     837procedure TDpiApplication.SetShowMainForm(AValue: Boolean);
     838begin
     839  GetVclApplication.ShowMainForm := AValue;
     840end;
     841
     842procedure TDpiApplication.SetTitle(AValue: string);
     843begin
     844  GetVclApplication.Title := AValue;
     845end;
     846
     847function TDpiApplication.GetVclApplication: TApplication;
     848begin
     849  Result := Application;
     850end;
     851
     852procedure TDpiApplication.Run;
     853begin
     854  if (FMainForm <> nil) and GetShowMainForm then FMainForm.Show;
     855  GetVclApplication.Run;
     856end;
     857
     858procedure TDpiApplication.Initialize;
     859begin
     860  GetVclApplication.Initialize;
     861end;
     862
     863procedure TDpiApplication.ProcessMessages;
     864begin
     865  GetVclApplication.ProcessMessages;
     866end;
     867
     868procedure TDpiApplication.UpdateMainForm(AForm: TDpiForm);
     869begin
     870  if (FMainForm = nil)
     871  and (FCreatingForm=AForm)
     872  //and (not (AppDestroying in FFlags))
     873  and not (AForm.FormStyle in [fsMDIChild, fsSplash])
     874  then
     875    FMainForm := AForm;
     876  GetVclApplication.UpdateMainForm(AForm.GetVclForm);
     877end;
     878
     879procedure TDpiApplication.CreateForm(InstanceClass: TComponentClass; out
     880  Reference);
     881var
     882  Instance: TComponent;
     883  ok: Boolean;
     884  AForm: TDpiForm;
     885begin
     886  // Allocate the instance, without calling the constructor
     887  Instance := TComponent(InstanceClass.NewInstance);
     888  // set the Reference before the constructor is called, so that
     889  // events and constructors can refer to it
     890  TComponent(Reference) := Instance;
     891
     892  ok := False;
     893  try
     894    if (FCreatingForm = nil) and (Instance is TDpiForm) then
     895      FCreatingForm := TDpiForm(Instance);
     896    Instance.Create(Self);
     897    ok := true;
     898  finally
     899    if not ok then begin
     900      TComponent(Reference) := nil;
     901      if FCreatingForm = Instance then
     902        FCreatingForm := nil;
     903    end;
     904  end;
     905
     906  if (Instance is TDpiForm) then begin
     907    AForm := TDpiForm(Instance);
     908    UpdateMainForm(AForm);
     909    if FMainForm = AForm then AForm.GetVclForm.HandleNeeded;
     910    if AForm.FormStyle = fsSplash then begin
     911      // show the splash form and handle the paint message
     912      AForm.Show;
     913      AForm.Invalidate;
     914      ProcessMessages;
     915    end;
     916  end;
     917end;
     918
    547919{ TDpiJpegImage }
    548920
     
    578950end;
    579951
     952function TDpiCustomControl.GetPixelsPerInch: Integer;
     953begin
     954//  Result := GetVclCustomControl.P;
     955end;
     956
     957function TDpiCustomControl.GetCanvas: TDpiCanvas;
     958begin
     959  if not Assigned(FCanvas) then begin
     960    FCanvas := TDpiCanvas.Create;
     961    FCanvas.VclCanvas := GetVclCustomControl.Canvas;
     962  end;
     963  Result := FCanvas;
     964end;
     965
    580966procedure TDpiCustomControl.SetOnPaint(AValue: TNotifyEvent);
    581967begin
    582968  GetVclCustomControl.OnPaint := AValue;
     969end;
     970
     971procedure TDpiCustomControl.SetPixelsPerInch(AValue: Integer);
     972begin
     973
    583974end;
    584975
     
    7151106function TDpiBitmap.GetCanvas: TDpiCanvas;
    7161107begin
    717   if not Assigned(FCanvas) then FCanvas := TDpiCanvas.Create;
     1108  if not Assigned(FCanvas) then begin
     1109    FCanvas := TDpiCanvas.Create;
     1110    FCanvas.VclCanvas := GetVclBitmap.Canvas;
     1111  end;
    7181112  Result := FCanvas;
    7191113end;
     
    7751169constructor TDpiBitmap.Create;
    7761170begin
     1171  inherited;
    7771172end;
    7781173
     
    7841179end;
    7851180
     1181procedure TDpiBitmap.Assign(Source: TPersistent);
     1182begin
     1183  if Source is TDpiBitmap then begin
     1184    GetVclBitmap.Assign((Source as TDpiBitmap).GetVclBitmap);
     1185  end else inherited;
     1186end;
     1187
    7861188function TDpiBitmap.GetVclRasterImage: TRasterImage;
    7871189begin
     
    8151217end;
    8161218
    817 function TDpiPaintBox.GetVclControl: TControl;
     1219function TDpiPaintBox.GetVclGraphicControl: TGraphicControl;
    8181220begin
    8191221  if not Assigned(VclPaintBox) then VclPaintBox := TPaintBox.Create(nil);
     
    9101312function TDpiCanvas.GetVclCanvas: TCanvas;
    9111313begin
    912   if not Assigned(VclCanvas) then VclCanvas := TCanvas.Create;
     1314  //if not Assigned(VclCanvas) then VclCanvas := TCanvas.Create;
    9131315  Result := VclCanvas;
    9141316end;
     
    9991401end;
    10001402
    1001 function TDpiGraphicControl.GetOnPaint: TNotifyEvent;
    1002 begin
    1003   Result := nil;
    1004 end;
    1005 
    1006 procedure TDpiGraphicControl.SetOnPaint(AValue: TNotifyEvent);
    1007 begin
    1008 
     1403procedure TDpiGraphicControl.PaintHandler(Sender: TObject);
     1404begin
     1405  Paint;
     1406  if Assigned(FOnPaint) then
     1407    FOnPaint(Sender);
    10091408end;
    10101409
     
    10201419function TDpiGraphicControl.GetVclGraphicControl: TGraphicControl;
    10211420begin
    1022   Result := nil;
     1421  if not Assigned(VclGraphicControl) then begin
     1422    VclGraphicControl := TGraphicControlEx.Create(nil);
     1423    (VclGraphicControl as TGraphicControlEx).OnPaint := @PaintHandler;
     1424  end;
     1425  Result := VclGraphicControl;
     1426end;
     1427
     1428procedure TDpiGraphicControl.UpdateVclControl;
     1429begin
     1430  inherited;
     1431  (GetVclGraphicControl as TGraphicControlEx).OnMouseDown := @MouseDownHandler;
     1432  (GetVclGraphicControl as TGraphicControlEx).OnMouseUp := @MouseUpHandler;
     1433  (GetVclGraphicControl as TGraphicControlEx).OnMouseMove := @MouseMoveHandler;
    10231434end;
    10241435
     
    10271438  inherited;
    10281439  FCanvas := TDpiCanvas.Create;
     1440  FCanvas.VclCanvas := GetVclGraphicControl.Canvas;
    10291441end;
    10301442
     
    11141526end;
    11151527
     1528function TDpiFont.GetCharSet: TFontCharSet;
     1529begin
     1530  Result := GetVclFont.CharSet;
     1531end;
     1532
     1533function TDpiFont.GetHeight: Integer;
     1534begin
     1535  Result := GetVclFont.Height;
     1536end;
     1537
    11161538function TDpiFont.GetPixelsPerInch: Integer;
    11171539begin
     
    11241546end;
    11251547
     1548function TDpiFont.IsNameStored: Boolean;
     1549begin
     1550  Result := GetVclFont.Name <> 'default';
     1551end;
     1552
     1553procedure TDpiFont.SetCharSet(AValue: TFontCharSet);
     1554begin
     1555  GetVclFont.CharSet := AValue;
     1556end;
     1557
    11261558procedure TDpiFont.SetColor(AValue: TColor);
    11271559begin
     
    11291561end;
    11301562
     1563procedure TDpiFont.SetHeight(AValue: Integer);
     1564begin
     1565  GetVclFont.Height := AValue;
     1566end;
     1567
    11311568procedure TDpiFont.SetName(AValue: string);
    11321569begin
     
    11441581end;
    11451582
    1146 procedure TDpiFont.Assign(Source: TDpiFont);
    1147 begin
    1148   GetVclFont.Assign(Source.GetVclFont);
    1149   Size := Source.Size;
    1150   FOnChange := Source.FOnChange;
     1583procedure TDpiFont.Assign(Source: TPersistent);
     1584begin
     1585  if Source is TDpiFont then begin
     1586    GetVclFont.Assign((Source as TDpiFont).GetVclFont);
     1587    Size := (Source as TDpiFont).Size;
     1588    FOnChange := (Source as TDpiFont).FOnChange;
     1589  end;
    11511590end;
    11521591
     
    11911630begin
    11921631  GetVclWinControl.OnKeyUp := AValue;
    1193 
    11941632end;
    11951633
     
    12451683end;
    12461684
     1685procedure TDpiScreen.SetActiveForm(AValue: TDpiForm);
     1686begin
     1687  FActiveForm := AValue;
     1688end;
     1689
    12471690function TDpiScreen.GetHeight: Integer;
    12481691begin
     
    12721715  Forms := TDpiForms.Create;
    12731716  Forms.FreeObjects := False;
    1274   Dpi := 96;
     1717  Dpi := 144;
    12751718end;
    12761719
     
    13301773end;
    13311774
     1775procedure TDpiControl.MouseDownHandler(Sender: TObject; Button: TMouseButton;
     1776  Shift: TShiftState; X, Y: Integer);
     1777begin
     1778  MouseDown(Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
     1779  if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
     1780end;
     1781
     1782procedure TDpiControl.MouseUpHandler(Sender: TObject; Button: TMouseButton;
     1783  Shift: TShiftState; X, Y: Integer);
     1784begin
     1785  MouseUp(Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
     1786  if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
     1787end;
     1788
     1789procedure TDpiControl.MouseMoveHandler(Sender: TObject; Shift: TShiftState; X,
     1790  Y: Integer);
     1791begin
     1792  MouseMove(Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
     1793  if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, ScaleFromVcl(X), ScaleFromVcl(Y));
     1794end;
     1795
     1796procedure TDpiControl.MouseWheelHandler(Sender: TObject; Shift: TShiftState;
     1797  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
     1798begin
     1799  if Assigned(FOnMouseWheel) then FOnMouseWheel(Self, Shift, WheelDelta,
     1800    ScalePointFromVcl(MousePos), Handled);
     1801end;
     1802
    13321803procedure TDpiControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
    13331804  Y: Integer);
    13341805begin
    1335   // TODO
    13361806end;
    13371807
     
    13391809  Y: Integer);
    13401810begin
    1341   // TODO
    13421811end;
    13431812
    13441813procedure TDpiControl.MouseMove(Shift: TShiftState; X, Y: Integer);
    13451814begin
    1346   // TODO
    13471815end;
    13481816
     
    13921860  FFont := TDpiFont.Create;
    13931861  FFont.OnChange := @FontChanged;
     1862  FConstraints := TDpiSizeConstraints.Create;
    13941863  if Assigned(TheOwner) and (TheOwner is TDpiWinControl) then
    13951864    Parent := TDpiWinControl(TheOwner);
     
    14011870destructor TDpiControl.Destroy;
    14021871begin
     1872  FreeAndNil(FConstraints);
    14031873  FreeAndNil(FFont);
    14041874  inherited Destroy;
     
    14671937end;
    14681938
     1939function TDpiControl.GetColor: TColor;
     1940begin
     1941  Result := GetVclControl.Color;
     1942end;
     1943
     1944function TDpiControl.GetCursor: TCursor;
     1945begin
     1946  Result := GetVclControl.Cursor;
     1947end;
     1948
    14691949function TDpiControl.GetEnabled: Boolean;
    14701950begin
     
    15101990begin
    15111991  GetVclControl.ClientWidth := ScaletoVcl(AValue);
     1992end;
     1993
     1994procedure TDpiControl.SetColor(AValue: TColor);
     1995begin
     1996  GetVclControl.Color := AValue;
     1997end;
     1998
     1999procedure TDpiControl.SetCursor(AValue: TCursor);
     2000begin
     2001  GetVclControl.Cursor := AValue;
    15122002end;
    15132003
     
    15462036
    15472037procedure TDpiControl.VclChangeBounds(Sender: TObject);
    1548 begin
    1549   BoundsRect := ScaleRectFromVcl(GetVclControl.BoundsRect);
    1550   DoChangeBounds;
     2038var
     2039  NewBounds: TRect;
     2040begin
     2041  NewBounds := ScaleRectFromVcl(GetVclControl.BoundsRect);
     2042  if NewBounds <> BoundsRect then begin
     2043    BoundsRect := NewBounds;
     2044    DoChangeBounds;
     2045  end;
    15512046end;
    15522047
     
    16132108function TDpiForm.GetBorderIcons: TBorderIcons;
    16142109begin
    1615   Result := VclForm.BorderIcons;
     2110  Result := GetVclForm.BorderIcons;
    16162111end;
    16172112
    16182113function TDpiForm.GetBorderStyle: TBorderStyle;
    16192114begin
    1620   Result := VclForm.BorderStyle;
    1621 end;
    1622 
    1623 function TDpiForm.GetCanvas: TDpiCanvas;
    1624 begin
    1625   Result := Canvas;
     2115  Result := GetVclForm.BorderStyle;
     2116end;
     2117
     2118function TDpiForm.GetDesignTimePPI: Integer;
     2119begin
     2120  Result := GetVclForm.DesignTimePPI;
    16262121end;
    16272122
    16282123function TDpiForm.GetFormState: TFormState;
    16292124begin
    1630   Result := VclForm.FormState;
     2125  Result := GetVclForm.FormState;
     2126end;
     2127
     2128function TDpiForm.GetFormStyle: TFormStyle;
     2129begin
     2130  Result := GetVclForm.FormStyle;
     2131end;
     2132
     2133function TDpiForm.GetKeyPreview: Boolean;
     2134begin
     2135  Result := GetVclForm.KeyPreview;
     2136end;
     2137
     2138function TDpiForm.GetLCLVersion: string;
     2139begin
     2140  Result := GetVclForm.LCLVersion;
    16312141end;
    16322142
    16332143function TDpiForm.GetModalResult: TModalResult;
    16342144begin
    1635   Result := VclForm.ModalResult;
     2145  Result := GetVclForm.ModalResult;
    16362146end;
    16372147
    16382148function TDpiForm.GetOnClose: TCloseEvent;
    16392149begin
    1640   Result := VclForm.OnClose;
     2150  Result := GetVclForm.OnClose;
     2151end;
     2152
     2153function TDpiForm.GetOnCloseQuery: TCloseQueryEvent;
     2154begin
     2155  Result := GetVclForm.OnCloseQuery;
    16412156end;
    16422157
    16432158function TDpiForm.GetOnCreate: TNotifyEvent;
    16442159begin
    1645   Result := VclForm.OnCreate;
     2160  Result := GetVclForm.OnCreate;
    16462161end;
    16472162
    16482163function TDpiForm.GetOnDeactivate: TNotifyEvent;
    16492164begin
    1650   Result := VclForm.OnDeactivate;
     2165  Result := GetVclForm.OnDeactivate;
    16512166end;
    16522167
    16532168function TDpiForm.GetOnDestroy: TNotifyEvent;
    16542169begin
    1655   Result := VclForm.OnDestroy;
     2170  Result := GetVclForm.OnDestroy;
    16562171end;
    16572172
    16582173function TDpiForm.GetOnHide: TNotifyEvent;
    16592174begin
    1660   Result := VclForm.OnHide;
     2175  Result := GetVclForm.OnHide;
    16612176end;
    16622177
    16632178function TDpiForm.GetOnShow: TNotifyEvent;
    16642179begin
    1665   Result := VclForm.OnShow;
     2180  Result := GetVclForm.OnShow;
     2181end;
     2182
     2183function TDpiForm.GetPosition: TPosition;
     2184begin
     2185  Result := GetVclForm.Position;
     2186end;
     2187
     2188function TDpiForm.GetWindowState: TWindowState;
     2189begin
     2190  Result := GetVclForm.WindowState;
    16662191end;
    16672192
    16682193procedure TDpiForm.SetBorderIcons(AValue: TBorderIcons);
    16692194begin
    1670   VclForm.BorderIcons := AValue;
     2195  GetVclForm.BorderIcons := AValue;
    16712196end;
    16722197
    16732198procedure TDpiForm.SetBorderStyle(AValue: TBorderStyle);
    16742199begin
    1675   VclForm.BorderStyle := AValue;
     2200  GetVclForm.BorderStyle := AValue;
     2201end;
     2202
     2203procedure TDpiForm.SetDesignTimePPI(AValue: Integer);
     2204begin
     2205  GetVclForm.DesignTimePPI := AValue;
     2206end;
     2207
     2208procedure TDpiForm.SetFormStyle(AValue: TFormStyle);
     2209begin
     2210  GetVclForm.FormStyle := AValue;
     2211end;
     2212
     2213procedure TDpiForm.SetKeyPreview(AValue: Boolean);
     2214begin
     2215  GetVclForm.KeyPreview := AValue;
     2216end;
     2217
     2218procedure TDpiForm.SetLCLVersion(AValue: string);
     2219begin
     2220  GetVclForm.LCLVersion := AValue;
    16762221end;
    16772222
    16782223procedure TDpiForm.SetModalResult(AValue: TModalResult);
    16792224begin
    1680   VclForm.ModalResult := AValue;
     2225  GetVclForm.ModalResult := AValue;
    16812226end;
    16822227
    16832228procedure TDpiForm.SetOnClose(AValue: TCloseEvent);
    16842229begin
    1685   VclForm.OnClose := AValue;
     2230  GetVclForm.OnClose := AValue;
     2231end;
     2232
     2233procedure TDpiForm.SetOnCloseQuery(AValue: TCloseQueryEvent);
     2234begin
     2235  GetVclForm.OnCloseQuery := AValue;
    16862236end;
    16872237
    16882238procedure TDpiForm.SetOnCreate(AValue: TNotifyEvent);
    16892239begin
    1690   VclForm.OnCreate := AValue;
     2240  GetVclForm.OnCreate := AValue;
    16912241end;
    16922242
    16932243procedure TDpiForm.SetOnDeactivate(AValue: TNotifyEvent);
    16942244begin
    1695   VclForm.OnDeactivate := AValue;
     2245  GetVclForm.OnDeactivate := AValue;
    16962246end;
    16972247
    16982248procedure TDpiForm.SetOnDestroy(AValue: TNotifyEvent);
    16992249begin
    1700   VclForm.OnDestroy := AValue;
     2250  GetVclForm.OnDestroy := AValue;
    17012251end;
    17022252
    17032253procedure TDpiForm.SetOnHide(AValue: TNotifyEvent);
    17042254begin
    1705   VclForm.OnHide := AValue;
     2255  GetVclForm.OnHide := AValue;
    17062256end;
    17072257
    17082258procedure TDpiForm.SetOnShow(AValue: TNotifyEvent);
    17092259begin
    1710   VclForm.OnShow := AValue;
     2260  GetVclForm.OnShow := AValue;
    17112261end;
    17122262
    17132263procedure TDpiForm.DoOnCreate;
    17142264begin
    1715   if Assigned(VclForm.OnCreate) then
    1716     VclForm.OnCreate(Self);
     2265  if Assigned(GetVclForm.OnCreate) then
     2266    GetVclForm.OnCreate(Self);
     2267end;
     2268
     2269procedure TDpiForm.FormMessageHandler(var TheMessage: TLMessage);
     2270begin
     2271  Dispatch(TheMessage);
     2272end;
     2273
     2274procedure TDpiForm.SetPosition(AValue: TPosition);
     2275begin
     2276  GetVclForm.Position := AValue;
     2277end;
     2278
     2279procedure TDpiForm.SetWindowState(AValue: TWindowState);
     2280begin
     2281  GetVclForm.WindowState := AValue;
     2282end;
     2283
     2284procedure TDpiForm.ActivateHandler(Sender: TObject);
     2285begin
     2286  DpiScreen.ActiveForm := Self;
     2287  if Assigned(FOnActivate) then FOnActivate(Sender);
     2288end;
     2289
     2290procedure TDpiForm.DeactivateHandler(Sender: TObject);
     2291begin
     2292  if Assigned(FOnDeactivate) then FOnDeactivate(Sender);
    17172293end;
    17182294
     
    17382314end;
    17392315
    1740 function TDpiForm.GetVclCustomControl: TCustomControl;
     2316function TDpiForm.GetVclScrollingWinControl: TScrollingWinControl;
    17412317begin
    17422318  Result := GetVclForm;
     
    17452321function TDpiForm.GetVclForm: TForm;
    17462322begin
    1747   if not Assigned(VclForm) then VclForm := TForm.Create(nil);
     2323  if not Assigned(VclForm) then begin
     2324    VclForm := TFormEx.Create(nil);
     2325    (VclForm as TFormEx).OnMessage := @FormMessageHandler;
     2326  end;
    17482327  Result := VclForm;
     2328end;
     2329
     2330procedure TDpiForm.UpdateVclControl;
     2331begin
     2332  inherited;
     2333  GetVclForm.OnMouseDown := @MouseDownHandler;
     2334  GetVclForm.OnMouseUp := @MouseUpHandler;
     2335  GetVclForm.OnMouseMove := @MouseMoveHandler;
     2336  GetVclForm.OnActivate := @ActivateHandler;
     2337  GetVclForm.OnDeactivate := @DeactivateHandler;
    17492338end;
    17502339
     
    17682357begin
    17692358  inherited;
    1770   DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);
     2359  //DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);
    17712360  GlobalNameSpace.BeginWrite;
    17722361  try
    1773     if (ClassType <> TDpiForm) and not (csDesigning in ComponentState)
    1774     then begin
     2362    if (ClassType <> TDpiForm) and not (csDesigning in ComponentState) then begin
    17752363      if not InitResourceComponent(Self, TDataModule) then begin
    17762364        raise EResNotFound.Create('Resource missing for class ' + ClassName);
     
    17922380initialization
    17932381
     2382RegisterPropertyToSkip(TDpiForm, 'OldCreateOrder', 'VCL compatibility property', '');
     2383RegisterPropertyToSkip(TDpiForm, 'TextHeight', 'VCL compatibility property', '');
     2384RegisterPropertyToSkip(TDpiForm, 'Scaled', 'VCL compatibility property', '');
     2385RegisterPropertyToSkip(TDpiForm, 'TransparentColorValue', 'VCL compatibility property', '');
    17942386DpiScreen := TDpiScreen.Create;
     2387DpiApplication := TDpiApplication.Create(nil);
    17952388
    17962389finalization
    17972390
     2391FreeAndNil(DpiApplication);
    17982392FreeAndNil(DpiScreen);
    17992393
Note: See TracChangeset for help on using the changeset viewer.