Skip to content
Permalink
Browse files

Update code from vcl-styles-utils to current master branch from Oct 1…

…0 2019. Closes #649. Also related to background color of selected VirtualTree nodes, reported in #789
  • Loading branch information...
ansgarbecker committed Nov 1, 2019
1 parent 9c67691 commit 1f17ed80c3e949f42411eae5fcdbc1fb34c5ac30
@@ -23,3 +23,36 @@
{$DEFINE HOOK_UXTHEME}
{$DEFINE HOOK_TDateTimePicker}
{$DEFINE HOOK_TProgressBar}
{.$DEFINE LimitStylesToCurrentProcess}

{ Feature toggles for supported UxThemes - see Vcl.Styles.UxTheme }

{$DEFINE HOOK_Button}
{$DEFINE HOOK_AllButtons}
{$DEFINE HOOK_Scrollbar}
{$DEFINE HOOK_TaskDialog}
{$DEFINE HOOK_ProgressBar}
{$DEFINE HOOK_DateTimePicker}
{$DEFINE HOOK_TreeView}
{$DEFINE HOOK_ListView}
{$DEFINE HOOK_ListBox}
{$DEFINE HOOK_ComboBox}

{$DEFINE HOOK_Spin}
{$DEFINE HOOK_EDIT}
{$DEFINE HOOK_Rebar}
{$DEFINE HOOK_ToolBar}
{$DEFINE HOOK_Menu}
{$DEFINE HOOK_TrackBar}
{$DEFINE HOOK_ToolTip}
{$DEFINE HOOK_Tab}
// Introduced in Windows Vista
{$DEFINE HOOK_CommandModule}
{$DEFINE HOOK_SearchBox}
{$DEFINE HOOK_AddressBand}
{$DEFINE HOOK_PreviewPane}
{$DEFINE HOOK_TRYHARDER}
{$DEFINE HOOK_BREADCRUMBAR}
{$DEFINE HOOK_InfoBar}
// Introduced in Windows 8
{$DEFINE HOOK_Navigation}
@@ -1,3 +1,32 @@
{
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)
@@ -6,22 +35,22 @@
History:
-----------------------------------------------------------------------------}
{
To use the unit just add it to the implementation uses statement of the main form and add
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 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.
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:
@@ -37,21 +66,31 @@ interface
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
{Rounds the scaling factorto the nearest 100%}
property RoundScalingFactor : Boolean read FRoundScalingFactor
write FRoundScalingFactor default True;
property UseCustomScalingFactor : Boolean read FUseCustomScalingFactor
@@ -62,10 +101,7 @@ TStyleDPIAwareness = class(TControl)
implementation

Uses
System.Rtti,
{$IFDEF VER330} // RAD Studio 10.3
DDetours;
{$ENDIF VER330}
System.Rtti, DDetours, System.Math;

{ TStyleDPIAwareness }

@@ -94,7 +130,8 @@ constructor TStyleDPIAwareness.Create(AOwner: TComponent);
inherited;
FRoundScalingFactor := True;
FUseCustomScalingFactor := False;
FCustomPPI :=96;
FCustomPPI := 96;
FOldDPI := 96;

FScaledStyles := TStringList.Create;
FScaledStyles.Sorted := False;
@@ -108,54 +145,68 @@ destructor TStyleDPIAwareness.Destroy;
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
Screen.Forms[i].Perform(CM_RECREATEWND, 0, 0);
begin
if Screen.Forms[i] <> TForm(Owner) then
Screen.Forms[i].Perform(CM_RECREATEWND, 0, 0);
end;
end;

procedure TStyleDPIAwareness.ScaleStyle(Style: TCustomStyleServices);
Var
DPI : integer;
NewDPI : integer;
SeStyle : TObject;
SeStyleSource : TObject;
BitmapList : TList;
BitMap : TBitmap;
StyleObjectList : Tlist;
i : integer;
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, mulDiv(BLType.GetProperty('Bottom').GetValue(BL).AsInteger, DPI, 96));
BLType.GetProperty('Right').SetValue(BL, mulDiv(BLType.GetProperty('Right').GetValue(BL).AsInteger, DPI, 96));
BLType.GetProperty('Left').SetValue(BL, mulDiv(BLType.GetProperty('Left').GetValue(BL).AsInteger, DPI, 96));
BLType.GetProperty('Top').SetValue(BL, mulDiv(BLType.GetProperty('Top').GetValue(BL).AsInteger, DPI, 96));
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, mulDiv(aSOType.GetProperty('Top').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('Left').SetValue(aSO, mulDiv(aSOType.GetProperty('Left').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('Width').SetValue(aSO, mulDiv(aSOType.GetProperty('Width').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('Height').SetValue(aSO, mulDiv(aSOType.GetProperty('Height').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('MarginTop').SetValue(aSO, mulDiv(aSOType.GetProperty('MarginTop').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('MarginLeft').SetValue(aSO, mulDiv(aSOType.GetProperty('MarginLeft').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('MarginBottom').SetValue(aSO, mulDiv(aSOType.GetProperty('MarginBottom').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('MarginRight').SetValue(aSO, mulDiv(aSOType.GetProperty('MarginRight').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('TextMarginTop').SetValue(aSO, mulDiv(aSOType.GetProperty('TextMarginTop').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('TextMarginLeft').SetValue(aSO, mulDiv(aSOType.GetProperty('TextMarginLeft').GetValue(aSO).AsInteger, DPI, 96));
aSOType.GetProperty('TextMarginRight').SetValue(aSO, mulDiv(aSOType.GetProperty('TextMarginRight').GetValue(aSO).AsInteger, DPI, 96));
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;
i: integer;
ChildSo : TComponent;
SOType : TRTTIType;
BitmapLink : TObject;
@@ -178,7 +229,7 @@ procedure TStyleDPIAwareness.ScaleStyle(Style: TCustomStyleServices);
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, DPI, 96));
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;;
@@ -209,28 +260,29 @@ procedure TStyleDPIAwareness.ScaleStyle(Style: TCustomStyleServices);
end;

begin
// Check if Style already scaled then
if FScaledStyles.IndexOf(Style.Name) >= 0 then
Exit;
n := FScaledStyles.IndexOf(TStyleManager.ActiveStyle.Name);
if n >= 0 then
begin
obj := TStyleDPI(FScaledStyles.Objects[n]);
OldDPI := obj.FCurrentDPI;
end;

if UseCustomScalingFactor then
DPI := CustomPPI
else begin
DPI := Screen.PixelsPerInch;
if FRoundScalingFactor then
DPI := Round(DPI / 96) * 96;
end;
NewDPI := CustomPPI
else
NewDPI := TForm(Owner).Monitor.PixelsPerInch;

if (Style = TStyleManager.SystemStyle) or (DPI <= 120) then
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
if BitMapList.Count = 1 then
begin
Bitmap := TObject(BitmapList[0]) as TBitmap;
ResizeBitmap(Bitmap, MulDiv(Bitmap.Width, DPI, 96), Muldiv(Bitmap.Height, DPI, 96));
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
@@ -240,7 +292,20 @@ procedure TStyleDPIAwareness.ScaleStyle(Style: TCustomStyleServices);
TRttiContext.Create.GetType(SeStyle.ClassType).GetMethod('ResetStyle').Invoke(SeStyle, []);

end;
FScaledStyles.Add(Style.Name);

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;
@@ -281,9 +346,9 @@ function TFormStyleHookFix.Detour_GetBorderSize: TRect;
TMethod(MethodPtr).Code := TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code;
TMethod(MethodPtr).Data := Pointer(Self);
Result := MethodPtr;
Self.SetStretchedCaptionInc(0);
if (Screen.PixelsPerInch > 96) then
Result.Top := MulDiv(Result.Top, 96, Screen.PixelsPerInch);
Self.SetStretchedCaptionInc(1);
if (Form.Monitor.PixelsPerInch > 96) then
Result.Top := MulDiv(Result.Top, 96, Form.Monitor.PixelsPerInch);
end;

initialization
@@ -370,9 +370,9 @@ class function TStyleManagerHelper.RegisteredStyles: TDictionary<string, TSource
Offset = SizeOf(Pointer) * 3;
{$IFEND}
var
t: TPair<string, TStyleManager.TSourceInfo>;
t: TPair<string, TSourceInfo>;
SourceInfo: TSourceInfo;
LRegisteredStyles: TDictionary<string, TStyleManager.TSourceInfo>;
LRegisteredStyles: TDictionary<string, TSourceInfo>;
{$IF (CompilerVersion >= 31)}
p: Pointer;
{$IFEND}
@@ -408,7 +408,7 @@ class function TStyleManagerHelper.RegisteredStyles: TDictionary<string, TSource
{$ELSE}
p := Pointer(PByte(@Self.Flags) + 4);
{$ENDIF CPUX64}
LRegisteredStyles := TDictionary<string, TStyleManager.TSourceInfo>(p^);
LRegisteredStyles := TDictionary<string, TSourceInfo>(p^);
{$IFEND}
for t in LRegisteredStyles do
begin
@@ -30,11 +30,6 @@ interface
uses
WinApi.Windows;

var
Trampoline_user32_GetSysColorBrush: function(nIndex: Integer): HBRUSH; stdcall;
Trampoline_user32_GetSysColor: function(nIndex: Integer): DWORD; stdcall;


implementation

{$I VCL.Styles.Utils.inc}
@@ -52,9 +47,9 @@ implementation
WinApi.UXTheme,
Vcl.Graphics,
Vcl.Styles.Utils.Graphics,
{$IFDEF HOOK_UXTHEME}
{$IFDEF HOOK_UXTHEME}
Vcl.Styles.UxTheme,
{$ENDIF HOOK_UXTHEME}
{$ENDIF HOOK_UXTHEME}
Vcl.Styles.Utils.SysControls,
Vcl.Styles.FontAwesome,
Vcl.Forms,
@@ -84,8 +79,11 @@ TCommonCalendarClass = class(TCommonCalendar);
Trampoline_user32_DrawEdge : function(hDC: hDC; var qrc: TRect; edge: UINT; grfFlags: UINT): BOOL; stdcall = nil;
Trampoline_user32_DrawFrameControl : function (DC: HDC; Rect: PRect; uType, uState: UINT): BOOL; stdcall = nil;
Trampoline_user32_LoadIconW : function (hInstance: HINST; lpIconName: PWideChar): HICON; stdcall = nil;
Trampoline_user32_GetSysColorBrush: function(nIndex: Integer): HBRUSH; stdcall;
{$IFDEF HOOK_UXTHEME}
Trampoline_user32_LoadImageW: function (hInst: HINST; ImageName: LPCWSTR; ImageType: UINT; X, Y: Integer; Flags: UINT): THandle; stdcall = nil;
{$ELSE}
Trampoline_user32_GetSysColor: function(nIndex: Integer): DWORD; stdcall;
{$ENDIF HOOK_UXTHEME}

{$IFDEF HOOK_TDateTimePicker}

0 comments on commit 1f17ed8

Please sign in to comment.
You can’t perform that action at this time.