Changeset 255 for branches

Timestamp:

Jun 9, 2020, 12:43:25 AM (4 years ago)

Author:

chronos

Message:

• Fixed: Some memory leaks in DpiControls.

Location:

branches/highdpi

Files:

• LocalPlayer/Help.pas (modified) (1 diff)
• Packages/DpiControls/UDpiControls.pas (modified) (36 diffs)

branches/highdpi/LocalPlayer/Help.pas

@@ -477 +477 @@
               ((y + ScaleToNative(dy)) shr 1 < ScaleToNative(nHeaven)) and
               (ImpPtr[dy].Pixel^.B shl 16 + ImpPtr[dy].Pixel^.G shl 8 +
-              ImpPtr[dy].Pixel^.R = Heaven[(ScaleFromNative(y) + dy) shr 1]) then
+              ImpPtr[dy].Pixel^.R = Heaven[(ScaleFromNative(y + ScaleToNative(dy))) shr 1]) then
               Sum := Sum + 9 * 255
             else

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -8 +8 @@
   {$IFDEF WINDOWS}Windows, {$ENDIF}Classes, SysUtils, LCLProc, LResources, Forms, FormEditingIntf, ProjectIntf,
   Controls, StdCtrls, fgl, Graphics, ComCtrls, ExtCtrls, LCLType, GraphType,
-  Types, CustApp, LMessages, LCLIntf, Menus;
+  Types, CustApp, LMessages, LCLIntf, Menus, Math;
 
 type
@@ -63 +63 @@
   TDpiFont = class(TPersistent)
   private
+    FNativeFont: TFont;
+    FNativeFontFree: Boolean;
     FOnChange: TNotifyEvent;
     FSize: Integer;
@@ -80 +82 @@
     procedure SetHeight(AValue: Integer);
     procedure SetName(AValue: string);
+    procedure SetNativeFont(AValue: TFont);
     procedure SetOnChange(AValue: TNotifyEvent);
     procedure SetPixelsPerInch(AValue: Integer);
@@ -90 +93 @@
     function GetNativeFont: TFont; virtual;
   public
-    NativeFont: TFont;
+    property NativeFont: TFont read FNativeFont write SetNativeFont;
     constructor Create;
     destructor Destroy; override;
@@ -299 +302 @@
   private
     FFont: TDpiFont;
+    FFontFree: Boolean;
     FNativeCanvas: TCanvas;
+    FNativeCanvasFree: Boolean;
     function GetBrush: TBrush;
     function GetHandle: HDC;
@@ -418 +423 @@
     function GetNativeCustomControl: TCustomControl; virtual;
   public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
     property Canvas: TDpiCanvas read GetCanvas;
   published
@@ -784 +791 @@
     NativeJpeg: TJPEGImage;
     constructor Create; override;
+    destructor Destroy; override;
   end;
 
@@ -795 +803 @@
     NativePng: TPortableNetworkGraphic;
     constructor Create; override;
+    destructor Destroy; override;
   end;
 
@@ -953 +962 @@
 function ScaleFloatToNative(Value: Double): Double;
 function ScaleFloatFromNative(Value: Double): Double;
-
+procedure WriteLog(Text: string);
 
 implementation
@@ -1001 +1010 @@
 end;
 
+function Ceil(const X: Single): Integer;
+begin
+  if X > High(Integer) then
+    Result := High(Integer)
+  else if X < Low(Integer) then
+    Result := Low(Integer)
+  else begin
+    Result := Trunc(X);
+    if (Result <> X) then begin
+      if (Result > 0) then Inc(Result) else Dec(Result);
+    end;
+  end;
+end;
+
 function ScaleToNative(Value: Integer): Integer;
 begin
@@ -1059 +1082 @@
 begin
   Result := Value * 96 / DpiScreen.Dpi;
+end;
+
+procedure WriteLog(Text: string);
+var
+  F: Text;
+const
+  FileName = 'Log.txt';
+begin
+  AssignFile(F, FileName);
+  if FileExists(FileName) then Append(F) else Rewrite(F);
+  WriteLn(F, Text);
+  CloseFile(F);
 end;
 
@@ -1330 +1365 @@
 destructor TDpiMenuItem.Destroy;
 begin
+  FreeAndNil(NativeMenuItem);
   FreeAndNil(FItems);
   inherited Destroy;
@@ -1630 +1666 @@
 function TDpiJpegImage.GetNativeJpeg: TJPEGImage;
 begin
-  if not Assigned(NativeJpeg) then NativeJpeg := TJPEGImage.Create;
   Result := NativeJpeg;
 end;
@@ -1636 +1671 @@
 constructor TDpiJpegImage.Create;
 begin
+  NativeJpeg := TJPEGImage.Create;
   inherited;
   NativeGraphicClass := TJPEGImage;
 end;
 
+destructor TDpiJpegImage.Destroy;
+begin
+  FreeAndNil(NativeJpeg);
+  inherited Destroy;
+end;
+
 { TDpiPortableNetworkGraphic }
 
@@ -1649 +1691 @@
 function TDpiPortableNetworkGraphic.GetNativePng: TPortableNetworkGraphic;
 begin
-  if not Assigned(NativePng) then NativePng := TPortableNetworkGraphic.Create;
   Result := NativePng;
 end;
@@ -1655 +1696 @@
 constructor TDpiPortableNetworkGraphic.Create;
 begin
+  NativePng := TPortableNetworkGraphic.Create;
   inherited;
   NativeGraphicClass := TPortableNetworkGraphic;
 end;
 
+destructor TDpiPortableNetworkGraphic.Destroy;
+begin
+  Canvas.NativeCanvas := nil;
+  FreeAndNil(NativePng);
+  inherited;
+end;
+
 { TDpiCustomControl }
 
@@ -1668 +1717 @@
 function TDpiCustomControl.GetPixelsPerInch: Integer;
 begin
-//  Result := GetNativeCustomControl.P;
+  //Result := GetNativeCustomControl.Pix;
 end;
 
 function TDpiCustomControl.GetCanvas: TDpiCanvas;
 begin
-  if not Assigned(FCanvas) then begin
-    FCanvas := TDpiCanvas.Create;
-    FCanvas.NativeCanvas := GetNativeCustomControl.Canvas;
-  end;
   Result := FCanvas;
 end;
@@ -1698 +1743 @@
 begin
   Result := nil;
+end;
+
+constructor TDpiCustomControl.Create(TheOwner: TComponent);
+begin
+  inherited;
+  FCanvas := TDpiCanvas.Create;
+  FCanvas.NativeCanvas := GetNativeCustomControl.Canvas;
+end;
+
+destructor TDpiCustomControl.Destroy;
+begin
+  FreeAndNil(FCanvas);
+  inherited;
 end;
 
@@ -1793 +1851 @@
 function TDpiRasterImage.GetNativeRasterImage: TRasterImage;
 begin
-  Result := GetNativeRasterImage;
+  Result := nil;
 end;
 
@@ -1868 +1926 @@
 function TDpiBitmap.GetCanvas: TDpiCanvas;
 begin
-  if not Assigned(FCanvas) then begin
-    FCanvas := TDpiCanvas.Create;
-    FCanvas.NativeCanvas := GetNativeBitmap.Canvas;
-  end;
   Result := FCanvas;
 end;
@@ -1929 +1983 @@
 function TDpiBitmap.GetNativeBitmap: TCustomBitmap;
 begin
-  if not Assigned(NativeBitmap) then begin
-    NativeBitmap := TBitmap.Create;
-    Canvas.NativeCanvas := NativeBitmap.Canvas;
-  end;
   Result := NativeBitmap;
 end;
@@ -1957 +2007 @@
   inherited;
   NativeGraphicClass := TBitmap;
+  NativeBitmap := TBitmap.Create;
+  FCanvas := TDpiCanvas.Create;
+  FCanvas.NativeCanvas := GetNativeBitmap.Canvas;
 end;
 
@@ -2168 +2221 @@
 begin
   if FFont = AValue then Exit;
+  if FFontFree then FreeAndNil(FFont);
+  FFontFree := False;
   FFont := AValue;
 end;
@@ -2200 +2255 @@
 begin
   if FNativeCanvas = AValue then Exit;
+  if FNativeCanvasFree then FreeAndNil(FNativeCanvas);
+  FNativeCanvasFree := False;
   FNativeCanvas := AValue;
-  FFont.NativeFont := FNativeCanvas.Font;
+  if Assigned(FNativeCanvas) then begin
+    FFont.NativeFont := FNativeCanvas.Font;
+  end;
 end;
 
 function TDpiCanvas.GetNativeCanvas: TCanvas;
 begin
-  //if not Assigned(NativeCanvas) then NativeCanvas := TCanvas.Create;
   Result := NativeCanvas;
 end;
@@ -2289 +2347 @@
 constructor TDpiCanvas.Create;
 begin
+  FNativeCanvas := nil;
   FFont := TDpiFont.Create;
+  FFontFree := True;
 end;
 
 destructor TDpiCanvas.Destroy;
 begin
-  FreeAndNil(FFont);
+  if FFontFree then FreeAndNil(FFont);
+  if FNativeCanvasFree then FreeAndNil(FNativeCanvasFree);
   inherited;
 end;
@@ -2324 +2385 @@
 function TDpiGraphicControl.GetNativeGraphicControl: TGraphicControl;
 begin
-  if not Assigned(NativeGraphicControl) then begin
-    NativeGraphicControl := TGraphicControl.Create(nil);
-  end;
   Result := NativeGraphicControl;
 end;
@@ -2348 +2406 @@
 constructor TDpiGraphicControl.Create(TheOwner: TComponent);
 begin
+  NativeGraphicControl := TGraphicControl.Create(nil);
   inherited;
   FCanvas := TDpiCanvas.Create;
@@ -2356 +2415 @@
 begin
   FreeAndNil(FCanvas);
+  FreeAndNil(NativeGraphicControl);
   inherited;
 end;
@@ -2410 +2470 @@
 procedure TDpiFont.UpdateFont;
 begin
-  GetNativeFont.PixelsPerInch := FPixelsPerInch;
-  GetNativeFont.Size := FSize;
+  if Assigned(GetNativeFont) then begin
+    GetNativeFont.PixelsPerInch := FPixelsPerInch;
+    GetNativeFont.Size := FSize;
+  end;
 end;
 
@@ -2421 +2483 @@
 function TDpiFont.GetNativeFont: TFont;
 begin
-  if not Assigned(NativeFont) then NativeFont := TFont.Create;
   Result := NativeFont;
 end;
@@ -2502 +2563 @@
 end;
 
+procedure TDpiFont.SetNativeFont(AValue: TFont);
+begin
+  if FNativeFont = AValue then Exit;
+  if FNativeFontFree then FNativeFont.Free;
+  FNativeFontFree := False;
+  FNativeFont := AValue;
+end;
+
 constructor TDpiFont.Create;
 begin
+  FNativeFont := TFont.Create;
+  FNativeFontFree := True;
   FPixelsPerInch := DpiScreen.PixelsPerInch;
   Size := 8;
@@ -2510 +2581 @@
 destructor TDpiFont.Destroy;
 begin
-  inherited Destroy;
+  if FNativeFontFree then
+    FreeAndNil(FNativeFont);
+  inherited;
 end;
 
@@ -2733 +2806 @@
 begin
   //Dpi := 96 * 2; //Screen.PixelsPerInch;
+  //Dpi := 144; //Round(96 * 1.25)
+  //Dpi := Round(96 * 1.6);
   Dpi := Screen.PixelsPerInch;
 end;
@@ -3162 +3237 @@
   NewBounds := ScaleRectFromNative(GetNativeControl.BoundsRect);
   if NewBounds <> BoundsRect then begin
-    BoundsRect := NewBounds;
+    FLeft := NewBounds.Left;
+    FTop := NewBounds.Top;
+    FWidth := NewBounds.Width;
+    FHeight := NewBounds.Height;
     DoChangeBounds;
   end;
@@ -3169 +3247 @@
 procedure TDpiControl.DoFormResize;
 begin
-  if Assigned(FOnResize) then FOnResize(Self);
+  if Assigned(FOnResize) then begin
+    FOnResize(Self);
+  end;
 end;
 
@@ -3188 +3268 @@
 
 procedure TDpiControl.UpdateBounds;
+var
+  R: TRect;
 begin
   GetNativeControl.BoundsRect := ScaleRectToNative(BoundsRect);
+  R := ScaleRectToNative(BoundsRect);
+  //WriteLog(Name + ' ' + IntToStr(R.Left) + ', ' + IntToStr(R.Top) + ', ' + IntToStr(R.Width) + ', ' + IntToStr(R.Height))
 end;