ewsdr/WindowsDPI.pas

unit WindowsDPI;

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

interface

procedure EnableProcessDpiAwareness;

implementation

{$IFDEF MSWINDOWS}
uses
  Windows;

type
  TDpiAwarenessContext = THandle;
  TSetProcessDpiAwarenessContext = function(Value: TDpiAwarenessContext): BOOL; stdcall;
  TSetProcessDpiAwareness = function(Value: Integer): HRESULT; stdcall;
  TSetProcessDPIAware = function: BOOL; stdcall;

const
  DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2 = TDpiAwarenessContext(PtrInt(-4));
  DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE    = TDpiAwarenessContext(PtrInt(-3));
  PROCESS_PER_MONITOR_DPI_AWARE              = 2;

function TrySetDpiAwarenessContext(Value: TDpiAwarenessContext): Boolean;
var
  User32: HMODULE;
  Proc: TSetProcessDpiAwarenessContext;
begin
  Result := False;
  User32 := GetModuleHandle('user32.dll');
  if User32 = 0 then Exit;
  Proc := TSetProcessDpiAwarenessContext(GetProcAddress(User32, 'SetProcessDpiAwarenessContext'));
  if Assigned(Proc) then
    Result := Proc(Value);
end;

function TrySetDpiAwarenessShcore: Boolean;
var
  Shcore: HMODULE;
  Proc: TSetProcessDpiAwareness;
begin
  Result := False;
  Shcore := LoadLibrary('shcore.dll');
  if Shcore = 0 then Exit;
  try
    Proc := TSetProcessDpiAwareness(GetProcAddress(Shcore, 'SetProcessDpiAwareness'));
    if Assigned(Proc) then
      Result := Proc(PROCESS_PER_MONITOR_DPI_AWARE) >= 0;
  finally
    FreeLibrary(Shcore);
  end;
end;

function TrySetSystemDpiAware: Boolean;
var
  User32: HMODULE;
  Proc: TSetProcessDPIAware;
begin
  Result := False;
  User32 := GetModuleHandle('user32.dll');
  if User32 = 0 then Exit;
  Proc := TSetProcessDPIAware(GetProcAddress(User32, 'SetProcessDPIAware'));
  if Assigned(Proc) then
    Result := Proc();
end;

procedure EnableProcessDpiAwareness;
begin
  if TrySetDpiAwarenessContext(DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2) then Exit;
  if TrySetDpiAwarenessContext(DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE) then Exit;
  if TrySetDpiAwarenessShcore then Exit;
  TrySetSystemDpiAware;
end;

{$ELSE}
procedure EnableProcessDpiAwareness;
begin
end;
{$ENDIF}

end.