Ignore:
Timestamp:
Jun 9, 2020, 12:43:25 AM (4 years ago)
Author:
chronos
Message:
File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/highdpi/Packages/DpiControls/UDpiControls.pas

    r254 r255  
    88  {$IFDEF WINDOWS}Windows, {$ENDIF}Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf,
    99  Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType, GraphType,
    10   Types, CustApp, LMessages, LCLIntf, Menus;
     10  Types, CustApp, LMessages, LCLIntf, Menus, Math;
    1111
    1212type
     
    6363  TDpiFont = class(TPersistent)
    6464  private
     65    FNativeFont: TFont;
     66    FNativeFontFree: Boolean;
    6567    FOnChange: TNotifyEvent;
    6668    FSize: Integer;
     
    8082    procedure SetHeight(AValue: Integer);
    8183    procedure SetName(AValue: string);
     84    procedure SetNativeFont(AValue: TFont);
    8285    procedure SetOnChange(AValue: TNotifyEvent);
    8386    procedure SetPixelsPerInch(AValue: Integer);
     
    9093    function GetNativeFont: TFont; virtual;
    9194  public
    92     NativeFont: TFont;
     95    property NativeFont: TFont read FNativeFont write SetNativeFont;
    9396    constructor Create;
    9497    destructor Destroy; override;
     
    299302  private
    300303    FFont: TDpiFont;
     304    FFontFree: Boolean;
    301305    FNativeCanvas: TCanvas;
     306    FNativeCanvasFree: Boolean;
    302307    function GetBrush: TBrush;
    303308    function GetHandle: HDC;
     
    418423    function GetNativeCustomControl: TCustomControl; virtual;
    419424  public
     425    constructor Create(TheOwner: TComponent); override;
     426    destructor Destroy; override;
    420427    property Canvas: TDpiCanvas read GetCanvas;
    421428  published
     
    784791    NativeJpeg: TJPEGImage;
    785792    constructor Create; override;
     793    destructor Destroy; override;
    786794  end;
    787795
     
    795803    NativePng: TPortableNetworkGraphic;
    796804    constructor Create; override;
     805    destructor Destroy; override;
    797806  end;
    798807
     
    953962function ScaleFloatToNative(Value: Double): Double;
    954963function ScaleFloatFromNative(Value: Double): Double;
    955 
     964procedure WriteLog(Text: string);
    956965
    957966implementation
     
    10011010end;
    10021011
     1012function Ceil(const X: Single): Integer;
     1013begin
     1014  if X > High(Integer) then
     1015    Result := High(Integer)
     1016  else if X < Low(Integer) then
     1017    Result := Low(Integer)
     1018  else begin
     1019    Result := Trunc(X);
     1020    if (Result <> X) then begin
     1021      if (Result > 0) then Inc(Result) else Dec(Result);
     1022    end;
     1023  end;
     1024end;
     1025
    10031026function ScaleToNative(Value: Integer): Integer;
    10041027begin
     
    10591082begin
    10601083  Result := Value * 96 / DpiScreen.Dpi;
     1084end;
     1085
     1086procedure WriteLog(Text: string);
     1087var
     1088  F: Text;
     1089const
     1090  FileName = 'Log.txt';
     1091begin
     1092  AssignFile(F, FileName);
     1093  if FileExists(FileName) then Append(F) else Rewrite(F);
     1094  WriteLn(F, Text);
     1095  CloseFile(F);
    10611096end;
    10621097
     
    13301365destructor TDpiMenuItem.Destroy;
    13311366begin
     1367  FreeAndNil(NativeMenuItem);
    13321368  FreeAndNil(FItems);
    13331369  inherited Destroy;
     
    16301666function TDpiJpegImage.GetNativeJpeg: TJPEGImage;
    16311667begin
    1632   if not Assigned(NativeJpeg) then NativeJpeg := TJPEGImage.Create;
    16331668  Result := NativeJpeg;
    16341669end;
     
    16361671constructor TDpiJpegImage.Create;
    16371672begin
     1673  NativeJpeg := TJPEGImage.Create;
    16381674  inherited;
    16391675  NativeGraphicClass := TJPEGImage;
    16401676end;
    16411677
     1678destructor TDpiJpegImage.Destroy;
     1679begin
     1680  FreeAndNil(NativeJpeg);
     1681  inherited Destroy;
     1682end;
     1683
    16421684{ TDpiPortableNetworkGraphic }
    16431685
     
    16491691function TDpiPortableNetworkGraphic.GetNativePng: TPortableNetworkGraphic;
    16501692begin
    1651   if not Assigned(NativePng) then NativePng := TPortableNetworkGraphic.Create;
    16521693  Result := NativePng;
    16531694end;
     
    16551696constructor TDpiPortableNetworkGraphic.Create;
    16561697begin
     1698  NativePng := TPortableNetworkGraphic.Create;
    16571699  inherited;
    16581700  NativeGraphicClass := TPortableNetworkGraphic;
    16591701end;
    16601702
     1703destructor TDpiPortableNetworkGraphic.Destroy;
     1704begin
     1705  Canvas.NativeCanvas := nil;
     1706  FreeAndNil(NativePng);
     1707  inherited;
     1708end;
     1709
    16611710{ TDpiCustomControl }
    16621711
     
    16681717function TDpiCustomControl.GetPixelsPerInch: Integer;
    16691718begin
    1670 //  Result := GetNativeCustomControl.P;
     1719  //Result := GetNativeCustomControl.Pix;
    16711720end;
    16721721
    16731722function TDpiCustomControl.GetCanvas: TDpiCanvas;
    16741723begin
    1675   if not Assigned(FCanvas) then begin
    1676     FCanvas := TDpiCanvas.Create;
    1677     FCanvas.NativeCanvas := GetNativeCustomControl.Canvas;
    1678   end;
    16791724  Result := FCanvas;
    16801725end;
     
    16981743begin
    16991744  Result := nil;
     1745end;
     1746
     1747constructor TDpiCustomControl.Create(TheOwner: TComponent);
     1748begin
     1749  inherited;
     1750  FCanvas := TDpiCanvas.Create;
     1751  FCanvas.NativeCanvas := GetNativeCustomControl.Canvas;
     1752end;
     1753
     1754destructor TDpiCustomControl.Destroy;
     1755begin
     1756  FreeAndNil(FCanvas);
     1757  inherited;
    17001758end;
    17011759
     
    17931851function TDpiRasterImage.GetNativeRasterImage: TRasterImage;
    17941852begin
    1795   Result := GetNativeRasterImage;
     1853  Result := nil;
    17961854end;
    17971855
     
    18681926function TDpiBitmap.GetCanvas: TDpiCanvas;
    18691927begin
    1870   if not Assigned(FCanvas) then begin
    1871     FCanvas := TDpiCanvas.Create;
    1872     FCanvas.NativeCanvas := GetNativeBitmap.Canvas;
    1873   end;
    18741928  Result := FCanvas;
    18751929end;
     
    19291983function TDpiBitmap.GetNativeBitmap: TCustomBitmap;
    19301984begin
    1931   if not Assigned(NativeBitmap) then begin
    1932     NativeBitmap := TBitmap.Create;
    1933     Canvas.NativeCanvas := NativeBitmap.Canvas;
    1934   end;
    19351985  Result := NativeBitmap;
    19361986end;
     
    19572007  inherited;
    19582008  NativeGraphicClass := TBitmap;
     2009  NativeBitmap := TBitmap.Create;
     2010  FCanvas := TDpiCanvas.Create;
     2011  FCanvas.NativeCanvas := GetNativeBitmap.Canvas;
    19592012end;
    19602013
     
    21682221begin
    21692222  if FFont = AValue then Exit;
     2223  if FFontFree then FreeAndNil(FFont);
     2224  FFontFree := False;
    21702225  FFont := AValue;
    21712226end;
     
    22002255begin
    22012256  if FNativeCanvas = AValue then Exit;
     2257  if FNativeCanvasFree then FreeAndNil(FNativeCanvas);
     2258  FNativeCanvasFree := False;
    22022259  FNativeCanvas := AValue;
    2203   FFont.NativeFont := FNativeCanvas.Font;
     2260  if Assigned(FNativeCanvas) then begin
     2261    FFont.NativeFont := FNativeCanvas.Font;
     2262  end;
    22042263end;
    22052264
    22062265function TDpiCanvas.GetNativeCanvas: TCanvas;
    22072266begin
    2208   //if not Assigned(NativeCanvas) then NativeCanvas := TCanvas.Create;
    22092267  Result := NativeCanvas;
    22102268end;
     
    22892347constructor TDpiCanvas.Create;
    22902348begin
     2349  FNativeCanvas := nil;
    22912350  FFont := TDpiFont.Create;
     2351  FFontFree := True;
    22922352end;
    22932353
    22942354destructor TDpiCanvas.Destroy;
    22952355begin
    2296   FreeAndNil(FFont);
     2356  if FFontFree then FreeAndNil(FFont);
     2357  if FNativeCanvasFree then FreeAndNil(FNativeCanvasFree);
    22972358  inherited;
    22982359end;
     
    23242385function TDpiGraphicControl.GetNativeGraphicControl: TGraphicControl;
    23252386begin
    2326   if not Assigned(NativeGraphicControl) then begin
    2327     NativeGraphicControl := TGraphicControl.Create(nil);
    2328   end;
    23292387  Result := NativeGraphicControl;
    23302388end;
     
    23482406constructor TDpiGraphicControl.Create(TheOwner: TComponent);
    23492407begin
     2408  NativeGraphicControl := TGraphicControl.Create(nil);
    23502409  inherited;
    23512410  FCanvas := TDpiCanvas.Create;
     
    23562415begin
    23572416  FreeAndNil(FCanvas);
     2417  FreeAndNil(NativeGraphicControl);
    23582418  inherited;
    23592419end;
     
    24102470procedure TDpiFont.UpdateFont;
    24112471begin
    2412   GetNativeFont.PixelsPerInch := FPixelsPerInch;
    2413   GetNativeFont.Size := FSize;
     2472  if Assigned(GetNativeFont) then begin
     2473    GetNativeFont.PixelsPerInch := FPixelsPerInch;
     2474    GetNativeFont.Size := FSize;
     2475  end;
    24142476end;
    24152477
     
    24212483function TDpiFont.GetNativeFont: TFont;
    24222484begin
    2423   if not Assigned(NativeFont) then NativeFont := TFont.Create;
    24242485  Result := NativeFont;
    24252486end;
     
    25022563end;
    25032564
     2565procedure TDpiFont.SetNativeFont(AValue: TFont);
     2566begin
     2567  if FNativeFont = AValue then Exit;
     2568  if FNativeFontFree then FNativeFont.Free;
     2569  FNativeFontFree := False;
     2570  FNativeFont := AValue;
     2571end;
     2572
    25042573constructor TDpiFont.Create;
    25052574begin
     2575  FNativeFont := TFont.Create;
     2576  FNativeFontFree := True;
    25062577  FPixelsPerInch := DpiScreen.PixelsPerInch;
    25072578  Size := 8;
     
    25102581destructor TDpiFont.Destroy;
    25112582begin
    2512   inherited Destroy;
     2583  if FNativeFontFree then
     2584    FreeAndNil(FNativeFont);
     2585  inherited;
    25132586end;
    25142587
     
    27332806begin
    27342807  //Dpi := 96 * 2; //Screen.PixelsPerInch;
     2808  //Dpi := 144; //Round(96 * 1.25)
     2809  //Dpi := Round(96 * 1.6);
    27352810  Dpi := Screen.PixelsPerInch;
    27362811end;
     
    31623237  NewBounds := ScaleRectFromNative(GetNativeControl.BoundsRect);
    31633238  if NewBounds <> BoundsRect then begin
    3164     BoundsRect := NewBounds;
     3239    FLeft := NewBounds.Left;
     3240    FTop := NewBounds.Top;
     3241    FWidth := NewBounds.Width;
     3242    FHeight := NewBounds.Height;
    31653243    DoChangeBounds;
    31663244  end;
     
    31693247procedure TDpiControl.DoFormResize;
    31703248begin
    3171   if Assigned(FOnResize) then FOnResize(Self);
     3249  if Assigned(FOnResize) then begin
     3250    FOnResize(Self);
     3251  end;
    31723252end;
    31733253
     
    31883268
    31893269procedure TDpiControl.UpdateBounds;
     3270var
     3271  R: TRect;
    31903272begin
    31913273  GetNativeControl.BoundsRect := ScaleRectToNative(BoundsRect);
     3274  R := ScaleRectToNative(BoundsRect);
     3275  //WriteLog(Name + ' ' + IntToStr(R.Left) + ', ' + IntToStr(R.Top) + ', ' + IntToStr(R.Width) + ', ' + IntToStr(R.Height))
    31923276end;
    31933277
Note: See TracChangeset for help on using the changeset viewer.