{
  Copyright (C)
  2026 - Uladzimir Karpenka, EW8BAK

  This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either version 2
  of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}

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.
