paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 13:59:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

win32: DPI-aware themes

Browse Source
This commit is contained in:
Ondrej Pokorny 2022-11-15 23:03:34 +01:00
parent 877d933344
commit df7568471d
2 changed files with 71 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
lcl/interfaces/win32/win32int.pp
View File

@ -30,7 +30,7 @@ interface
}
uses
Windows, // keep as first
Classes, SysUtils, RtlConsts, ActiveX, MultiMon, CommCtrl, ctypes,
Classes, SysUtils, RtlConsts, ActiveX, MultiMon, CommCtrl, UxTheme, ctypes,
{$IF FPC_FULLVERSION>=30000}
character,
{$ENDIF}
@ -279,6 +279,7 @@ function GetDpiForWindow(hwnd: HWND): UINT;
function AdjustWindowRectExForDpi(const lpRect: LPRECT; dwStyle: DWORD; bMenu: BOOL; dwExStyle: DWORD; dpi: UINT): BOOL;
function GetDpiForMonitor(hmonitor: HMONITOR; dpiType: TMonitorDpiType; out dpiX: UINT; out dpiY: UINT): HRESULT;
function LoadIconWithScaleDown(hinst:HINST; pszName:LPCWStr;cx:cint;cy:cint;var phico: HICON ):HRESULT;
function OpenThemeDataForDpi(hwnd: HWND; pszClassList: LPCWSTR; dpi: UINT): HTHEME;
procedure AdjustFormClientToWindowSize(const AHandle: HANDLE; var ioSize: TSize); overload;
procedure AdjustFormClientToWindowSize(aHasMenu: Boolean; dwStyle, dwExStyle: DWORD; dpi: UINT; var ioSize: TSize); overload;
@ -330,6 +331,7 @@ type
TAdjustWindowRectExForDpi = function(const lpRect: LPRECT; dwStyle: DWORD; bMenu: BOOL; dwExStyle: DWORD; dpi: UINT): BOOL; stdcall;
TGetSystemMetricsForDpi = function (nIndex: Integer; dpi: UINT): Integer; stdcall;
TLoadIconWithScaleDown = function ( hinst:HINST; pszName:LPCWStr;cx:cint;cy:cint;var phico: HICON ):HRESULT; stdcall;
TOpenThemeDataForDpi = function (hwnd: HWND; pszClassList: LPCWSTR; dpi: UINT): HTHEME; stdcall;
TGetThreadDpiAwarenessContext = function (): DPI_AWARENESS_CONTEXT; stdcall;
TAreDpiAwarenessContextsEqual = function (dpiContextA, dpiContextB: DPI_AWARENESS_CONTEXT): BOOL; stdcall;
@ -339,6 +341,7 @@ var
g_AdjustWindowRectExForDpi: TAdjustWindowRectExForDpi = nil;
g_GetSystemMetricsForDpi: TGetSystemMetricsForDpi = nil;
g_LoadIconWithScaleDown: TLoadIconWithScaleDown = nil;
g_OpenThemeDataForDpi: TOpenThemeDataForDpi = nil;
g_GetThreadDpiAwarenessContext: TGetThreadDpiAwarenessContext = nil;
g_AreDpiAwarenessContextsEqual: TAreDpiAwarenessContextsEqual = nil;
g_HighDPIAPIDone: Boolean = False;
@ -368,6 +371,10 @@ begin
if lib<>0 then
Pointer(g_LoadIconWithScaleDown) := GetProcAddress(lib, 'LoadIconWithScaleDown');
lib := LoadLibrary('uxtheme.dll');
if lib<>0 then
Pointer(g_OpenThemeDataForDpi) := GetProcAddress(lib, 'OpenThemeDataForDpi');
g_HighDPIAPIDone := True;
end;
@ -439,6 +446,15 @@ begin
Result := S_FALSE;
end;
function OpenThemeDataForDpi(hwnd: HWND; pszClassList: LPCWSTR; dpi: UINT): HTHEME;
begin
InitHighDPIAPI;
if Assigned(g_OpenThemeDataForDpi) then
Result := g_OpenThemeDataForDpi(hwnd, pszClassList, dpi)
else
Result := OpenThemeData(hwnd, pszClassList);
end;
procedure AdjustFormClientToWindowSize(const AHandle: HANDLE; var ioSize: TSize);
{$IFNDEF LCLRealFormBounds}
var

61
lcl/interfaces/win32/win32themes.pas
View File

@ -1,6 +1,7 @@
unit Win32Themes;
{$mode objfpc}{$H+}
{$ModeSwitch arrayoperators}
{$I win32defines.inc}
interface
@ -16,13 +17,22 @@ uses
type
TThemeData = array[TThemedElement] of HTHEME;
TThemeDpiDataEntry = record
DPI: Integer;
Data: TThemeData;
end;
PThemeDpiDataEntry = ^TThemeDpiDataEntry;
TThemeDpiData = array of TThemeDpiDataEntry;
{ TWin32ThemeServices }
TWin32ThemeServices = class(TThemeServices)
private
FThemeData: TThemeData; // Holds a list of theme data handles.
FThemeDpiData: TThemeDpiData;
protected
function GetTheme(Element: TThemedElement): HTHEME;
function GetThemeForDPI(Element: TThemedElement; DPI: Integer): HTHEME;
function InitThemes: Boolean; override;
procedure UnloadThemeData; override;
function UseThemes: Boolean; override;
@ -61,6 +71,7 @@ type
function HasTransparentParts(Details: TThemedElementDetails): Boolean; override;
procedure PaintBorder(Control: TObject; EraseLRCorner: Boolean); override;
property Theme[Element: TThemedElement]: HTHEME read GetTheme;
property ThemeForDPI[Element: TThemedElement; DPI: Integer]: HTHEME read GetThemeForDPI;
end;
implementation
@ -141,15 +152,24 @@ const
{ TWin32ThemeServices }
procedure TWin32ThemeServices.UnloadThemeData;
procedure _Unload(_Theme: TThemeData);
var
Entry: TThemedElement;
begin
for Entry := Low(TThemeData) to High(TThemeData) do
if _Theme[Entry] <> 0 then
begin
CloseThemeData(_Theme[Entry]);
_Theme[Entry] := 0;
end;
end;
var
Entry: TThemedElement;
E: TThemeDpiDataEntry;
begin
for Entry := Low(TThemeData) to High(TThemeData) do
if FThemeData[Entry] <> 0 then
begin
CloseThemeData(FThemeData[Entry]);
FThemeData[Entry] := 0;
end;
_Unload(FThemeData);
for E in FThemeDpiData do
_Unload(E.Data);
FThemeDpiData := nil;
end;
function TWin32ThemeServices.InitThemes: Boolean;
@ -359,6 +379,33 @@ begin
Result := FThemeData[Element];
end;
function TWin32ThemeServices.GetThemeForDPI(Element: TThemedElement; DPI: Integer): HTHEME;
var
I: Integer;
E: PThemeDpiDataEntry;
begin
if (WindowsVersion < wv10) or (DPI=0) or (DPI=ScreenInfo.PixelsPerInchX) then
Exit(GetTheme(Element));
E := nil;
for I := 0 to High(FThemeDpiData) do
if FThemeDpiData[I].DPI=DPI then
begin
E := @FThemeDpiData[I];
break;
end;
if not Assigned(E) then
begin
FThemeDpiData := FThemeDpiData + [Default(TThemeDpiDataEntry)];
E := @FThemeDpiData[High(FThemeDpiData)];
E^.DPI := DPI;
end;
if (E^.Data[Element] = 0) then
E^.Data[Element] := OpenThemeDataForDpi(0, ThemeDataNamesVista[Element], DPI);
Result := E^.Data[Element];
end;
function TWin32ThemeServices.InternalColorToRGB(Details: TThemedElementDetails; Color: TColor): COLORREF;
begin
if ThemesEnabled then