mirror of
https://github.com/HeidiSQL/HeidiSQL.git
synced 2025-08-06 18:24:26 +08:00
367 lines
13 KiB
ObjectPascal
367 lines
13 KiB
ObjectPascal
{
|
|
Modified 20-Mar-2019 by Rickard Johansson (www.rj-texted.se).
|
|
Purpose: Add per-monitor DPI awareness
|
|
Usage: Add the unit to the interface uses statement of the main form and add code below:
|
|
|
|
TMyForm = class(TForm)
|
|
private
|
|
FStyleDPIAwareness: TStyleDPIAwareness;
|
|
|
|
procedure TFrmMain.FormCreate(Sender: TObject);
|
|
begin
|
|
FStyleDPIAwareness := TStyleDPIAwareness.Create(Self);
|
|
FStyleDPIAwareness.Parent := Self;
|
|
|
|
procedure TFrmMain.FormDestroy(Sender: TObject);
|
|
begin
|
|
FStyleDPIAwareness.Free;
|
|
|
|
procedure TFrmMain.FormAfterMonitorDpiChanged(Sender: TObject; OldDPI, NewDPI: Integer);
|
|
begin
|
|
FStyleDPIAwareness.AfterDPIChange(OldDPI, NewDPI);
|
|
end;
|
|
|
|
procedure TFrmMain.FormBeforeMonitorDpiChanged(Sender: TObject; OldDPI, NewDPI: Integer);
|
|
begin
|
|
FStyleDPIAwareness.BeforeDPIChange(OldDPI, NewDPI);
|
|
end;
|
|
}
|
|
|
|
{-----------------------------------------------------------------------------
|
|
Unit Name: VCL.Styles.DPIAware
|
|
Author: PyScripter (https://github.com/pyscripter)
|
|
Date: 13-Nov-2017
|
|
Purpose: Use VCL Styles in DPI Aware applications by scaling styles
|
|
History:
|
|
-----------------------------------------------------------------------------}
|
|
{
|
|
To use the unit just add it to the implementation uses statement of the main form and add
|
|
the following code to the FormCreate handler.
|
|
|
|
procedure TFrmMain.FormCreate(Sender: TObject);
|
|
Var
|
|
StyleDPIAwareness: TStyleDPIAwareness;
|
|
begin
|
|
StyleDPIAwareness := TStyleDPIAwareness.Create(Self);
|
|
StyleDPIAwareness.Parent := Self;
|
|
|
|
By default the component scales the styles at multiples of 100%. You can change that,
|
|
by adding the line:
|
|
|
|
StyleDPIAwareness.RoundScalingFactor := False;
|
|
|
|
With this statement styles are scaled to whatever scaling factor results for Screen.PixelsPerInch.
|
|
Most of the styles would work fine, but a few may show some visual defects.
|
|
|
|
Limitations:
|
|
Does not support perMonitor DPI Awareness.
|
|
You need to set DPI Awareness to System.
|
|
}
|
|
|
|
unit VCL.Styles.DPIAware;
|
|
|
|
interface
|
|
uses
|
|
Winapi.Windows, WinAPI.Messages, System.SysUtils, System.Classes, Vcl.Graphics,
|
|
Vcl.Controls, Vcl.Forms, Vcl.Themes, Vcl.Styles;
|
|
|
|
Type
|
|
TStyleDPI = class(TObject)
|
|
private
|
|
FCurrentDPI: Integer;
|
|
public
|
|
property CurrentDPI: Integer read FCurrentDPI write FCurrentDPI;
|
|
end;
|
|
|
|
TStyleDPIAwareness = class(TControl)
|
|
private
|
|
FScaledStyles: TStringList;
|
|
FRoundScalingFactor: Boolean;
|
|
FUseCustomScalingFactor: Boolean;
|
|
FCustomPPI: integer;
|
|
FOldDPI: Integer;
|
|
protected
|
|
procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED;
|
|
procedure RecreateForms;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure AfterDPIChange(OldDPI, NewDPI: Integer);
|
|
procedure BeforeDPIChange(OldDPI, NewDPI: Integer);
|
|
procedure ScaleStyle(Style: TCustomStyleServices);
|
|
property OldDPI: Integer read FOldDPI write FOldDPI;
|
|
published
|
|
property RoundScalingFactor: Boolean read FRoundScalingFactor
|
|
write FRoundScalingFactor default True;
|
|
property UseCustomScalingFactor: Boolean read FUseCustomScalingFactor
|
|
write FUseCustomScalingFactor default False;
|
|
property CustomPPI: integer read FCustomPPI write FCustomPPI default 96;
|
|
end;
|
|
|
|
implementation
|
|
|
|
Uses
|
|
System.Rtti, DDetours, System.Math;
|
|
|
|
{ TStyleDPIAwareness }
|
|
|
|
procedure ResizeBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer);
|
|
var
|
|
buffer: TBitmap;
|
|
begin
|
|
buffer := TBitmap.Create;
|
|
try
|
|
buffer.SetSize(NewWidth, NewHeight);
|
|
buffer.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), Bitmap);
|
|
Bitmap.SetSize(NewWidth, NewHeight);
|
|
Bitmap.Canvas.Draw(0, 0, buffer);
|
|
finally
|
|
buffer.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TStyleDPIAwareness.CMStyleChanged(var Message: TMessage);
|
|
begin
|
|
ScaleStyle(TStyleManager.ActiveStyle);
|
|
end;
|
|
|
|
constructor TStyleDPIAwareness.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FRoundScalingFactor := True;
|
|
FUseCustomScalingFactor := False;
|
|
FCustomPPI := 96;
|
|
FOldDPI := 96;
|
|
|
|
FScaledStyles := TStringList.Create;
|
|
FScaledStyles.Sorted := False;
|
|
|
|
ScaleStyle(TStyleManager.ActiveStyle);
|
|
end;
|
|
|
|
destructor TStyleDPIAwareness.Destroy;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FScaledStyles.Count - 1 do
|
|
TStyleDPI(FScaledStyles.Objects[i]).Free;
|
|
FScaledStyles.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TStyleDPIAwareness.AfterDPIChange(OldDPI, NewDPI: Integer);
|
|
begin
|
|
ScaleStyle(TStyleManager.ActiveStyle);
|
|
end;
|
|
|
|
procedure TStyleDPIAwareness.BeforeDPIChange(OldDPI, NewDPI: Integer);
|
|
begin
|
|
FOldDPI := OldDPI;
|
|
end;
|
|
|
|
procedure TStyleDPIAwareness.RecreateForms;
|
|
Var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to Screen.FormCount - 1 do
|
|
begin
|
|
if Screen.Forms[i] <> TForm(Owner) then
|
|
Screen.Forms[i].Perform(CM_RECREATEWND, 0, 0);
|
|
end;
|
|
end;
|
|
|
|
procedure TStyleDPIAwareness.ScaleStyle(Style: TCustomStyleServices);
|
|
Var
|
|
NewDPI: integer;
|
|
SeStyle: TObject;
|
|
SeStyleSource: TObject;
|
|
BitmapList: TList;
|
|
BitMap: TBitmap;
|
|
StyleObjectList: Tlist;
|
|
i,n: integer;
|
|
StyleObject: TComponent;
|
|
obj: TStyleDPI;
|
|
|
|
procedure ProcessBitmapLink(BL: TObject);
|
|
Var
|
|
BLType: TRTTIType;
|
|
begin
|
|
BLType := TRttiContext.Create.GetType(BL.ClassType);
|
|
BLType.GetProperty('Bottom').SetValue(BL, Round((BLType.GetProperty('Bottom').GetValue(BL).AsInteger * NewDPI - 1) / OldDPI));
|
|
BLType.GetProperty('Right').SetValue(BL, Round(BLType.GetProperty('Right').GetValue(BL).AsInteger * NewDPI / OldDPI));
|
|
BLType.GetProperty('Left').SetValue(BL, Round(BLType.GetProperty('Left').GetValue(BL).AsInteger * NewDPI / OldDPI));
|
|
BLType.GetProperty('Top').SetValue(BL, Round(BLType.GetProperty('Top').GetValue(BL).AsInteger * NewDPI / OldDPI));
|
|
end;
|
|
|
|
procedure ProcessSO(aSO: TComponent; aSOType: TRTTIType);
|
|
begin
|
|
aSOType.GetProperty('Top').SetValue(aSO, Round(aSOType.GetProperty('Top').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('Left').SetValue(aSO, Round(aSOType.GetProperty('Left').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('Width').SetValue(aSO, Round(aSOType.GetProperty('Width').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('Height').SetValue(aSO, Round(aSOType.GetProperty('Height').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('MarginTop').SetValue(aSO, Round(aSOType.GetProperty('MarginTop').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('MarginLeft').SetValue(aSO, Round(aSOType.GetProperty('MarginLeft').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('MarginBottom').SetValue(aSO, Round(aSOType.GetProperty('MarginBottom').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('MarginRight').SetValue(aSO, Round(aSOType.GetProperty('MarginRight').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('TextMarginTop').SetValue(aSO, Round(aSOType.GetProperty('TextMarginTop').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('TextMarginLeft').SetValue(aSO, Round(aSOType.GetProperty('TextMarginLeft').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
aSOType.GetProperty('TextMarginRight').SetValue(aSO, Round(aSOType.GetProperty('TextMarginRight').GetValue(aSO).AsInteger * NewDPI / OldDPI));
|
|
end;
|
|
|
|
procedure ProcessStyleObject(SO: TComponent);
|
|
var
|
|
i: integer;
|
|
ChildSo: TComponent;
|
|
SOType: TRTTIType;
|
|
BitmapLink: TObject;
|
|
begin
|
|
SOType := TRttiContext.Create.GetType(SO.ClassType);
|
|
ProcessSO(SO, SOType);
|
|
|
|
if So.ClassName = 'TSeBitmapObject' then begin
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
end;
|
|
|
|
if So.ClassName = 'TSeActiveBitmap' then begin
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FActiveBitmap').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
end;
|
|
|
|
if So.ClassName = 'TSeSystemButton' then begin
|
|
// Shift the form title to the right
|
|
if SO.Name = 'btnSysMenu' then
|
|
SOType.GetProperty('Width').SetValue(SO, MulDiv(28, NewDPI, OldDPI));
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FActiveBitmap').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapPressed').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapHot').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
end;
|
|
|
|
if So.ClassName = 'TSeButtonObject' then begin
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapFocused').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapHot').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapPressed').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapDisabled').GetValue(SO).AsObject;;
|
|
ProcessBitmapLink(BitmapLink);
|
|
end;
|
|
|
|
for i := 0 to SO.ComponentCount - 1 do begin
|
|
ChildSo := SO.Components[i];
|
|
ProcessStyleObject(ChildSo);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
n := FScaledStyles.IndexOf(TStyleManager.ActiveStyle.Name);
|
|
if n >= 0 then
|
|
begin
|
|
obj := TStyleDPI(FScaledStyles.Objects[n]);
|
|
OldDPI := obj.FCurrentDPI;
|
|
end;
|
|
|
|
if UseCustomScalingFactor then
|
|
NewDPI := CustomPPI
|
|
else
|
|
NewDPI := TForm(Owner).Monitor.PixelsPerInch;
|
|
|
|
if (Style = TStyleManager.SystemStyle) then
|
|
Exit;
|
|
|
|
SeStyle := TRttiContext.Create.GetType(Style.ClassType).GetField('FSource').GetValue(Style).AsObject;
|
|
SeStyleSource := TRttiContext.Create.GetType(SeStyle.ClassType).GetField('FCleanCopy').GetValue(SeStyle).AsObject;
|
|
BitMapList := TRttiContext.Create.GetType(SeStyleSource.ClassType).GetField('FBitmaps').GetValue(SeStyleSource).AsObject as TList;
|
|
|
|
if BitMapList.Count = 1 then
|
|
begin
|
|
Bitmap := TObject(BitmapList[0]) as TBitmap;
|
|
ResizeBitmap(Bitmap, Round(Bitmap.Width * NewDPI / OldDPI), Round(Bitmap.Height * NewDPI / OldDPI));
|
|
|
|
StyleObjectList := TRttiContext.Create.GetType(SeStyleSource.ClassType).GetField('FObjects').GetValue(SeStyleSource).AsObject as TList;
|
|
for i := 0 to StyleObjectList.Count -1 do begin
|
|
StyleObject := TObject(StyleObjectList[i]) as TComponent;
|
|
ProcessStyleObject(StyleObject);
|
|
end;
|
|
TRttiContext.Create.GetType(SeStyle.ClassType).GetMethod('ResetStyle').Invoke(SeStyle, []);
|
|
|
|
end;
|
|
|
|
n := FScaledStyles.IndexOf(Style.Name);
|
|
if n >= 0 then
|
|
begin
|
|
obj := TStyleDPI(FScaledStyles.Objects[n]);
|
|
obj.FCurrentDPI := NewDPI;
|
|
end
|
|
else
|
|
begin
|
|
obj := TStyleDPI.Create;
|
|
obj.FCurrentDPI := NewDPI;
|
|
FScaledStyles.AddObject(Style.Name, obj);
|
|
end;
|
|
|
|
if Style = TStyleManager.ActiveStyle then
|
|
RecreateForms;
|
|
end;
|
|
{$IFDEF VER330} // RAD Studio 10.3
|
|
type
|
|
TGetBorderSize = function: TRect of object;
|
|
|
|
TFormStyleHookFix = class helper for TFormStyleHook
|
|
procedure SetStretchedCaptionInc(Value: Integer);
|
|
function GetBorderSizeAddr: Pointer;
|
|
function Detour_GetBorderSize: TRect;
|
|
end;
|
|
|
|
var
|
|
Trampoline_TFormStyleHook_GetBorderSize: TGetBorderSize;
|
|
Detour_TFormStyleHook_GetBorderSize: TGetBorderSize;
|
|
|
|
|
|
{ TFormStyleHookFix }
|
|
|
|
function TFormStyleHookFix.GetBorderSizeAddr: Pointer;
|
|
var
|
|
MethodPtr: TGetBorderSize;
|
|
begin
|
|
with Self do MethodPtr := GetBorderSize;
|
|
Result := TMethod(MethodPtr).Code;
|
|
end;
|
|
|
|
procedure TFormStyleHookFix.SetStretchedCaptionInc(Value: Integer);
|
|
begin
|
|
with Self do FStretchedCaptionInc := Value;
|
|
end;
|
|
|
|
function TFormStyleHookFix.Detour_GetBorderSize: TRect;
|
|
var
|
|
MethodPtr: TGetBorderSize;
|
|
begin
|
|
TMethod(MethodPtr).Code := TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code;
|
|
TMethod(MethodPtr).Data := Pointer(Self);
|
|
Result := MethodPtr;
|
|
Self.SetStretchedCaptionInc(1);
|
|
if (Form.Monitor.PixelsPerInch > 96) then
|
|
Result.Top := MulDiv(Result.Top, 96, Form.Monitor.PixelsPerInch);
|
|
end;
|
|
|
|
initialization
|
|
Detour_TFormStyleHook_GetBorderSize := TFormStyleHook(nil).Detour_GetBorderSize;
|
|
TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code :=
|
|
InterceptCreate(TFormStyleHook(nil).GetBorderSizeAddr,
|
|
TMethod(Detour_TFormStyleHook_GetBorderSize).Code)
|
|
finalization
|
|
InterceptRemove(TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code);
|
|
{$ENDIF VER330}
|
|
end.
|