Changeset 353


Ignore:
Timestamp:
Apr 6, 2021, 11:03:40 PM (7 months ago)
Author:
chronos
Message:
  • Fixed: Pen Width also needs to be scaled. Added TDpiPen and TDpiBrush.
File:
1 edited

Legend:

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

    r349 r353  
    340340  end;
    341341
     342  { TDpiPen }
     343
     344  TDpiPen = class
     345    FWidth: Integer;
     346    FNativePen: TPen;
     347    FNativePenFree: Boolean;
     348  private
     349    function GetColor: TColor;
     350    function GetStyle: TPenStyle;
     351    function GetWidth: Integer;
     352    procedure SetColor(AValue: TColor);
     353    procedure SetNativePen(AValue: TPen);
     354    procedure SetStyle(AValue: TPenStyle);
     355    procedure SetWidth(AValue: Integer);
     356  public
     357    constructor Create;
     358    destructor Destroy; override;
     359    function GetNativePen: TPen;
     360    property NativePen: TPen read FNativePen write SetNativePen;
     361  published
     362    property Color: TColor read GetColor write SetColor default clBlack;
     363    property Style : TPenStyle read GetStyle write SetStyle default psSolid;
     364    property Width: Integer read GetWidth write SetWidth default 1;
     365  end;
     366
     367  { TDpiBrush }
     368
     369  TDpiBrush = class
     370  private
     371    FNativeBrush: TBrush;
     372    FNativeBrushFree: Boolean;
     373    function GetColor: TColor;
     374    function GetStyle: TBrushStyle;
     375    procedure SetColor(AValue: TColor);
     376    function GetNativeBrush: TBrush;
     377    procedure SetNativeBrush(AValue: TBrush);
     378    procedure SetStyle(AValue: TBrushStyle);
     379  public
     380    constructor Create;
     381    destructor Destroy; override;
     382    property NativeBrush: TBrush read FNativeBrush write SetNativeBrush;
     383  published
     384    property Color: TColor read GetColor write SetColor default clWhite;
     385    property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
     386  end;
     387
    342388  { TDpiCanvas }
    343389
    344390  TDpiCanvas = class
    345391  private
     392    FBrush: TDpiBrush;
     393    FBrushFree: Boolean;
     394    FPen: TDpiPen;
     395    FPenFree: Boolean;
    346396    FFont: TDpiFont;
    347397    FFontFree: Boolean;
    348398    FNativeCanvas: TCanvas;
    349399    FNativeCanvasFree: Boolean;
    350     function GetBrush: TBrush;
    351400    function GetHandle: HDC;
    352401    function GetHeight: Integer;
    353     function GetPen: TPen;
    354402    function GetPixel(X, Y: Integer): TColor;
    355403    function GetWidth: Integer;
    356     procedure SetBrush(AValue: TBrush);
     404    procedure SetBrush(AValue: TDpiBrush);
    357405    procedure SetFont(AValue: TDpiFont);
    358406    procedure SetHandle(AValue: HDC);
    359     procedure SetPen(AValue: TPen);
     407    procedure SetPen(AValue: TDpiPen);
    360408    procedure SetPixel(X, Y: Integer; AValue: TColor);
    361409    procedure SetNativeCanvas(AValue: TCanvas);
     
    386434    property Height: Integer read GetHeight;
    387435  published
    388     property Brush: TBrush read GetBrush write SetBrush;
    389     property Pen: TPen read GetPen write SetPen;
     436    property Brush: TDpiBrush read FBrush write SetBrush;
     437    property Pen: TDpiPen read FPen write SetPen;
    390438    property Font: TDpiFont read FFont write SetFont;
    391439  end;
     
    10761124function ScaleToNative(Value: Integer): Integer;
    10771125begin
    1078   Result := Trunc(Value * DpiScreen.Dpi / 96);
     1126  Result := Round(Value * DpiScreen.Dpi / 96);
    10791127end;
    10801128
     
    11901238 }
    11911239  {$ENDIF}
     1240end;
     1241
     1242{ TDpiPen }
     1243
     1244function TDpiPen.GetColor: TColor;
     1245begin
     1246  Result := GetNativePen.Color;
     1247end;
     1248
     1249function TDpiPen.GetStyle: TPenStyle;
     1250begin
     1251  Result := GetNativePen.Style;
     1252end;
     1253
     1254function TDpiPen.GetWidth: Integer;
     1255begin
     1256  Result := FWidth;
     1257end;
     1258
     1259procedure TDpiPen.SetColor(AValue: TColor);
     1260begin
     1261  GetNativePen.Color := AValue;
     1262end;
     1263
     1264procedure TDpiPen.SetNativePen(AValue: TPen);
     1265begin
     1266  if FNativePen = AValue then Exit;
     1267  if FNativePenFree then FreeAndNil(FNativePen);
     1268  FNativePenFree := False;
     1269  FNativePen := AValue;
     1270  SetWidth(FWidth);
     1271end;
     1272
     1273procedure TDpiPen.SetStyle(AValue: TPenStyle);
     1274begin
     1275  GetNativePen.Style := AValue;
     1276end;
     1277
     1278procedure TDpiPen.SetWidth(AValue: Integer);
     1279begin
     1280  GetNativePen.Width := ScaleToNative(AValue);
     1281  FWidth := AValue;
     1282end;
     1283
     1284constructor TDpiPen.Create;
     1285begin
     1286  FNativePen := TPen.Create;
     1287  FNativePenFree := True;
     1288  FWidth := 1;
     1289end;
     1290
     1291destructor TDpiPen.Destroy;
     1292begin
     1293  if FNativePenFree then
     1294    FreeAndNil(FNativePen);
     1295  inherited;
     1296end;
     1297
     1298function TDpiPen.GetNativePen: TPen;
     1299begin
     1300  Result := FNativePen;
     1301end;
     1302
     1303{ TDpiBrush }
     1304
     1305function TDpiBrush.GetColor: TColor;
     1306begin
     1307  Result := GetNativeBrush.Color;
     1308end;
     1309
     1310function TDpiBrush.GetStyle: TBrushStyle;
     1311begin
     1312  Result := GetNativeBrush.Style;
     1313end;
     1314
     1315procedure TDpiBrush.SetColor(AValue: TColor);
     1316begin
     1317  GetNativeBrush.Color := AValue;
     1318end;
     1319
     1320function TDpiBrush.GetNativeBrush: TBrush;
     1321begin
     1322  Result := FNativeBrush;
     1323end;
     1324
     1325procedure TDpiBrush.SetNativeBrush(AValue: TBrush);
     1326begin
     1327  if FNativeBrush = AValue then Exit;
     1328  if FNativeBrushFree then FreeAndNil(FNativeBrush);
     1329  FNativeBrushFree := False;
     1330  FNativeBrush := AValue;
     1331end;
     1332
     1333procedure TDpiBrush.SetStyle(AValue: TBrushStyle);
     1334begin
     1335  GetNativeBrush.Style := AValue;
     1336end;
     1337
     1338constructor TDpiBrush.Create;
     1339begin
     1340  FNativeBrush := TBrush.Create;
     1341  FNativeBrushFree := True;
     1342end;
     1343
     1344destructor TDpiBrush.Destroy;
     1345begin
     1346  if FNativeBrushFree then FreeAndNil(FNativeBrush);
     1347  inherited;
    11921348end;
    11931349
     
    24082564  Canvas := TDpiCanvas.Create;
    24092565  Canvas.NativeCanvas := NativePaintBox.Canvas;
    2410   Canvas.Font.NativeFont := NativePaintBox.Canvas.Font;
    24112566  UpdateNativeControl;
    24122567  ScreenChanged;
     
    24332588{ TDpiCanvas }
    24342589
    2435 function TDpiCanvas.GetBrush: TBrush;
    2436 begin
    2437   Result := GetNativeCanvas.Brush;
    2438 end;
    2439 
    24402590function TDpiCanvas.GetHandle: HDC;
    24412591begin
     
    24482598end;
    24492599
    2450 function TDpiCanvas.GetPen: TPen;
    2451 begin
    2452   Result := GetNativeCanvas.Pen;
    2453 end;
    2454 
    24552600function TDpiCanvas.GetPixel(X, Y: Integer): TColor;
    24562601begin
     
    24632608end;
    24642609
    2465 procedure TDpiCanvas.SetBrush(AValue: TBrush);
    2466 begin
    2467   GetNativeCanvas.Brush := AValue;
     2610procedure TDpiCanvas.SetBrush(AValue: TDpiBrush);
     2611begin
     2612  if FBrush = AValue then Exit;
     2613  if FBrushFree then FreeAndNil(FBrush);
     2614  FBrushFree := False;
     2615  FBrush := AValue;
    24682616end;
    24692617
     
    24812629end;
    24822630
    2483 procedure TDpiCanvas.SetPen(AValue: TPen);
    2484 begin
    2485   GetNativeCanvas.Pen := AValue;
     2631procedure TDpiCanvas.SetPen(AValue: TDpiPen);
     2632begin
     2633  if FPen = AValue then Exit;
     2634  if FPenFree then FreeAndNil(FPen);
     2635  FPenFree := False;
     2636  FPen := AValue;
    24862637end;
    24872638
     
    25102661  if Assigned(FNativeCanvas) then begin
    25112662    FFont.NativeFont := FNativeCanvas.Font;
     2663    FBrush.NativeBrush := FNativeCanvas.Brush;
     2664    FPen.NativePen := FNativeCanvas.Pen;
    25122665  end;
    25132666end;
     
    26002753  FFont := TDpiFont.Create;
    26012754  FFontFree := True;
     2755  FPen := TDpiPen.Create;
     2756  FPenFree := True;
     2757  FBrush := TDpiBrush.Create;
     2758  FBrushFree := True;
    26022759end;
    26032760
     
    26052762begin
    26062763  if FFontFree then FreeAndNil(FFont);
     2764  if FBrushFree then FreeAndNil(FBrush);
     2765  if FPenFree then FreeAndNil(FPen);
    26072766  if FNativeCanvasFree then FreeAndNil(FNativeCanvasFree);
    26082767  inherited;
Note: See TracChangeset for help on using the changeset viewer.