mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

FIX: Pixelated icons under Windows (issue #2584)

Browse source
This commit is contained in:
Alexander Koblov 2025-11-04 19:25:45 +03:00
commit a6c06d7866
2 changed files with 28 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

48
components/KASToolBar/kastoolbar.pas
View file

@ -234,6 +234,29 @@ begin
RegisterComponents('KASComponents',[TKASToolBar]);
end;
function findScaleFactorByFirstForm: Double;
begin
Result:= 1;
if Screen.FormCount > 0 then
Result:= Screen.Forms[0].GetCanvasScaleFactor();
end;
function findScaleFactorByControl( control: TControl ): Double;
var
topParent: TControl;
begin
if Assigned(control) then begin
topParent:= control.GetTopParent;
if Assigned(topParent) then
control:= topParent;
if (control is TWinControl) and TWinControl(control).HandleAllocated then begin
Result:= control.GetCanvasScaleFactor;
Exit;
end;
end;
Result:= findScaleFactorByFirstForm();
end;
{ TKASToolBar }
procedure TKASToolBar.InsertButton(InsertAt: Integer; ToolButton: TKASToolButton);
@ -572,6 +595,7 @@ begin
self.images.Width:= GlyphBitmapSize;
self.images.Height:= GlyphBitmapSize;
self.ImagesWidth:= FGlyphSize;
Self.Images.Scaled := (findScaleFactorByControl(Self) > 1.0);
BeginUpdate;
try
@ -870,7 +894,6 @@ constructor TKASToolBar.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
self.images:= TImageList.Create(self);
self.Images.Scaled:= True;
self.GlyphSize:= 16; // by default
FUpdateCount:= 0;
FButtonWidth := 23;
@ -1073,29 +1096,6 @@ begin
Buttons[I].Down:= False;
end;
function findScaleFactorByFirstForm: Double;
begin
Result:= 1;
if Screen.FormCount > 0 then
Result:= Screen.Forms[0].GetCanvasScaleFactor();
end;
function findScaleFactorByControl( control: TControl ): Double;
var
topParent: TControl;
begin
if Assigned(control) then begin
topParent:= control.GetTopParent;
if Assigned(topParent) then
control:= topParent;
if (control is TWinControl) and TWinControl(control).HandleAllocated then begin
Result:= control.GetCanvasScaleFactor;
Exit;
end;
end;
Result:= findScaleFactorByFirstForm();
end;
function TKASToolBar.GlyphBitmapSize: Integer;
begin
Result:= Round(FGlyphSize * findScaleFactorByControl(self));

6
src/platform/upixmapmanager.pas
View file

@ -476,16 +476,18 @@ procedure AssignRetinaBitmapForControl(
const imageSize: Integer;
bitmap: Graphics.TBitmap);
var
ScaleFactor: Double;
oldImages: TCustomImageList;
images: TImageList;
imageListSize: Integer;
begin
oldImages:= button.Images;
imageListSize := Round(imageSize * findScaleFactorByControl(button));
ScaleFactor := findScaleFactorByControl(button);
imageListSize := Round(imageSize * ScaleFactor);
images := TImageList.Create(button);
images.Width := imageListSize;
images.Height := imageListSize;
images.Scaled := True;
images.Scaled := (ScaleFactor > 1.0);
images.Add(bitmap, nil);
button.ImageWidth := imageSize;
button.Images := images;