How to fix Delphi VCL ScaleBy() TToolBar bug
The problem: when using ScaleBy() or the Windows high DPI scaling setting the TToolBars placed on the form are not repositioned and resized.
The solution: first put all TToolBar controls into a TPanel, that is placed at the same position and sized to the same size as the original TToolBar.
Set the TPanel's 'BevelOuter' to 'bvNone', and clear it's caption. Assign the same 'Anchors' as the TToolBar has.
Set the TToolBar that is inside the TPanel to Left = 0 and Top = 0.
This will solve the wrong position.
To fix the icon sizes, the TImageList holding the icons needs to be resized and the icons must be loaded dynamicaly.
Use the following code to resize the TImageList for example in FormCreate():
ImageListButtonIcons.Width := MulDiv(ImageListButtonIcons.Width, Screen.PixelsPerInch, 96);
ImageListButtonIcons.Height := MulDiv(ImageListButtonIcons.Height, Screen.PixelsPerInch, 96);
Then call the InitIcons procedure below:
procedure TMainForm.InitIcons;
var
Icon: TIcon;
begin
Icon := TIcon.Create;
try
Icon.SetSize(256, 256); //* Expecting large icons, at least that large like the scaling requires
Icon.Handle := LoadIcon(HInstance, PChar('ICON1'));
ImageListButtonIcons.AddIcon(Icon);
Icon.Handle := LoadIcon(HInstance, PChar('ICON2'));
ImageListButtonIcons.AddIcon(Icon);
//* Load all the icons here
finally
FreeAndNil(Icon);
end;
end;
You can use XN Resource Editor to create a .res file containing the icons, then add the .res file to the project with:
{$R Icons.res}
If you named the .res file as 'Icons.res'.
Use the following code to automaticaly wrap all TToolBars into a TPanel on the form, call this before calling ScaleBy():
procedure WrapTToolBarsInTPanel(Control: TWinControl; NewScale: Integer; OriginalScale: Integer);
var
i: Integer;
NewPanel: TPanel;
ToolBar: TToolBar;
begin
for i := Control.ControlCount - 1 downto 0 do begin
if i >= Control.ControlCount then begin
Continue;
end;
try
if (Control.Controls[i] is TToolBar)
AND ((Control.Controls[i] as TToolBar).Tag = 0)
then begin
ToolBar := Control.Controls[i] as TToolBar;
if Assigned(ToolBar.Images)
AND (ToolBar.Images.Tag = 0)
then begin
ToolBar.Images.Tag := 1;
ToolBar.Images.Width := MulDiv(ToolBar.Images.Width, NewScale, OriginalScale);
ToolBar.Images.Height := MulDiv(ToolBar.Images.Height, NewScale, OriginalScale);
end;
if Assigned(ToolBar.HotImages)
AND (ToolBar.HotImages.Tag = 0)
then begin
ToolBar.HotImages.Tag := 1;
ToolBar.HotImages.Width := MulDiv(ToolBar.HotImages.Width, NewScale, OriginalScale);
ToolBar.HotImages.Height := MulDiv(ToolBar.HotImages.Height, NewScale, OriginalScale);
end;
NewPanel := TPanel.Create(ToolBar.Parent);
NewPanel.Name := 'PanelFor' + ToolBar.Name;
NewPanel.Caption := '';
NewPanel.Parent := ToolBar.Parent;
NewPanel.BevelOuter := bvNone;
NewPanel.Left := ToolBar.Left;
NewPanel.Top := ToolBar.Top;
NewPanel.Width := ToolBar.Width;
NewPanel.Height := ToolBar.Height;
NewPanel.Anchors := ToolBar.Anchors;
NewPanel.Align := ToolBar.Align;
ToolBar.Parent := NewPanel;
ToolBar.Left := 0;
ToolBar.Top := 0;
ToolBar.Anchors := [akLeft, akTop];
ToolBar.Font.Size := MulDiv(ToolBar.Font.Size, NewScale, OriginalScale);
ToolBar.Tag := 1;
SendMessage(ToolBar.Handle, TB_AUTOSIZE, 0, 0);
end else begin
if Control.Controls[i] is TWinControl then begin
if (Control.Controls[i] as TWinControl).ControlCount > 0 then begin
WrapTToolBarsInTPanel(TWinControl(Control.Controls[i]), NewScale, OriginalScale);
end;
end;
end;
except
//*
end;
end;
end;
procedure FitTPanelToolBars(Control: TWinControl);
var
i: Integer;
Panel: TPanel;
ToolBar: TToolBar;
begin
for i := 0 to Control.ControlCount - 1 do begin
try
if Control.Controls[i] is TToolBar then begin
ToolBar := Control.Controls[i] as TToolBar;
if ToolBar.Parent is TPanel then begin
Panel := ToolBar.Parent as TPanel;
Panel.Width := ToolBar.Width + 2;
Panel.Height := ToolBar.Height + 2;
end;
end else begin
if Control.Controls[i] is TWinControl then begin
if (Control.Controls[i] as TWinControl).ControlCount > 0 then begin
FitTPanelToolBars(TWinControl(Control.Controls[i]));
end;
end;
end;
except
raise Exception.Create('Error: ' + ToolBar.Name + ' -> ' + ToolBar.Parent.Name);
end;
end;
end;
For example in FormCreate(), like:
procedure TForm1.FormCreate(Sender: TObject);
begin
WrapTToolBarsInTPanel(Self);
ScaleBy() here...
FitTPanelToolBars(Self);
end;
Additionaly to fix the TStatusBar panels' widths, use:
StatusBar.Height := MulDiv(StatusBar.Height, Screen.PixelsPerInch, 96);
for i := 0 to -1 + StatusBar.Panels.Count do begin
StatusBar.Panels[i].Width := MulDiv(StatusBar.Panels[i].Width, Screen.PixelsPerInch, 96);
end;
In the above codes use the needed scale value instead of 'Screen.PixelsPerInch' if using the ScaleBy() function manualy instead.
If you found the above information useful, please check my components.
|
