unit DllFuncReplace;

interface

uses
  WinApi.Windows;

procedure ReplaceDllFunc(const InModule: string; const AOldFuncAddr, ANewFuncAddr: FARPROC; const AhModule: HMODULE);

implementation

uses
  System.SysUtils, WinApi.ImageHlp;

function SameTextUnicode(const S1, S2: UnicodeString): Boolean;
begin
  Result := WinApi.Windows.CompareStringW(WinApi.Windows.LOCALE_INVARIANT, WinApi.Windows.NORM_IGNORECASE, PWideChar(S1),
    Length(S1), PWideChar(S2), Length(S2)) = CSTR_EQUAL;
end;

procedure ReplaceDllFunc(const InModule: string; const AOldFuncAddr, ANewFuncAddr: FARPROC; const AhModule: HMODULE);
var
  ASize: ULONG;
  lpflProtect: DWORD;
  AThunk: PPointer;
  AImportEntry: PImageImportDescriptor;
  ModuleName: string;
begin
  try
    AImportEntry := ImageDirectoryEntryToData(Pointer(AhModule), ByteBool(1), IMAGE_DIRECTORY_ENTRY_IMPORT, ASize);
    while Assigned(AImportEntry) and (AImportEntry^.Name <> 0) do
    begin
      ModuleName := UnicodeString(PAnsiChar(AhModule + AImportEntry.name));
      AThunk := Pointer(NativeUInt(AhModule) + AImportEntry^.FirstThunk);
      while Assigned(AThunk) and Assigned(AThunk^) do
      begin
        if SameTextUnicode(ModuleName, InModule) then
        begin
          if (AThunk^ = Pointer(AOldFuncAddr)) then
          begin
            if not IsBadWritePtr(AThunk, SizeOf(NativeUInt)) then
            begin
              AThunk^ := ANewFuncAddr;
            end
            else
            begin
              {$WARN SYMBOL_PLATFORM OFF}
              Win32Check(
                VirtualProtect(AThunk, SizeOf(NativeUInt), PAGE_EXECUTE_READWRITE, lpflProtect)
              );
              AThunk^ := ANewFuncAddr;
              Win32Check(
                VirtualProtect(AThunk, SizeOf(NativeUInt), lpflProtect, lpflProtect)
              );
              {$WARN SYMBOL_PLATFORM ON}
            end;
            OutputDebugString(PChar(Format('[0x%s]@ReplaceIATEntry: address=0x%s -> address=0x%s',
              [IntToHex(NativeUInt(AThunk), 2 * SizeOf(NativeUInt)), IntToHex(NativeUInt(AOldFuncAddr), 2 * SizeOf(NativeUInt)), IntToHex(NativeUInt(ANewFuncAddr), 2 * SizeOf(NativeUInt))])));
          end;
        end;
        Inc(AThunk);
      end;
      AImportEntry  := Pointer(NativeUInt(AImportEntry) + SizeOf(TImageImportDescriptor));
    end;
  except
    on E: Exception do
    begin
      // Win32Check Error
      OutputDebugString(PChar('ReplaceIATEntry@' + E.ClassName + ': ' + E.Message));
    end;
  end;
end;

end.

unit SysPaletteInterceptor;

interface

procedure InterceptPalette;

implementation

uses
  Winapi.Windows, DllFuncReplace,
  Winapi.UxTheme;

type
  TSystemPalette = packed array[0..31] of COLORREF;
  TSystemBrushes = packed array[0..31] of HBRUSH;

const
  // from 0 to 31
  FSysPaletteHex: AnsiString =
  'D4D0C8003A6EA5000A246A0080808000D4D0C800FFFFFF00000000000000000000000000FFFFFF00D4D0C800D4D0C800808080000A246A00FFFFFF00D4D0C800' +
  '808080008080800000000000D4D0C800FFFFFF0040404000D4D0C80000000000FFFFE100B5B5B50000008000A6CAF000C0C0C0000A246A00D4D0C80000000000';
  // in 32..255 there are zeroes


var
  FSystemPalette: TSystemPalette;
  FSystemBrushes: TSystemBrushes;

procedure BinToHex(Buffer: PAnsiChar; Text: PAnsiChar; BufSize: Integer);
const
  Convert: array[0..15] of AnsiChar = AnsiString('0123456789ABCDEF');
var
  I: Integer;
begin
  for I := 0 to BufSize - 1 do
  begin
    Text[0] := Convert[Byte(Buffer[I]) shr 4];
    Text[1] := Convert[Byte(Buffer[I]) and $F];
    Inc(Text, 2);
  end;
end;

function HexToBin(Text : PAnsiChar; Buffer: PAnsiChar; BufSize: Integer): Integer;
const
  Convert: array['0'..'f'] of SmallInt =
    ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15);
var
  I: Integer;
begin
  I := BufSize;
  while I > 0 do
  begin
    if not (Text[0] in ['0'..'f']) or not (Text[1] in ['0'..'f']) then Break;
    Buffer[0] := AnsiChar((Convert[Text[0]] shl 4) + Convert[Text[1]]);
    Inc(Buffer);
    Inc(Text, 2);
    Dec(I);
  end;
  Result := BufSize - I;
end;


function AnsiHex2Bin(const HexSource: AnsiString): AnsiString;
begin
  SetLength(Result, Length(HexSource) div 2);
  if Length(Result) > 0 then
    HexToBin(PAnsiChar(HexSource), PAnsiChar(Result), Length(Result))
end;

function AnsiBin2Hex(const Source: AnsiString): AnsiString;
begin
  SetLength(Result, Length(Source) * 2);
  if Length(Source) > 0 then
    BinToHex(PAnsiChar(Source), PAnsiChar(Result), Length(Source));
end;

function GetSystemPalette: TSystemPalette;
var
  I: Byte;
begin
  for I := 0 to High(TSystemPalette) do
    Result[I] := GetSysColor(I);
end;

var
  FSafeGetSysColor: function(nIndex: Integer): DWORD; stdcall;
  FSafeGetThemeSysColor: function(hTheme: HTHEME; iColorId: Integer): COLORREF; stdcall;
  FSafeGetSysColorBrush: function(nIndex: Integer): HBRUSH; stdcall;

function InterceptGetSysColor(nIndex: Integer): DWORD; stdcall;
begin
  if (nIndex >= 0) and (nIndex < 256) then
  begin
    if (nIndex >= 0) and (nIndex < 32) then
      Result := FSystemPalette[nIndex]
    else
      Result := 0;
  end
  else
    Result := FSafeGetSysColor(nIndex);
end;

function InterceptGetThemeSysColor(hTheme: HTHEME; iColorId: Integer): COLORREF; stdcall;
begin
  if (iColorId >= 0) and (iColorId < 32) then
  begin
    Result := FSystemPalette[iColorId]
  end
  else
    Result := FSafeGetThemeSysColor(hTheme, iColorId);
end;

function InterceptGetSysColorBrush(nIndex: Integer): HBRUSH; stdcall;
begin
  if (nIndex >= 0) and (nIndex < 32) then
    Result := FSystemBrushes[nIndex]
  else
    Result := FSafeGetSysColorBrush(nIndex);
end;

procedure InterceptPalette;
var
  SysPaletteBin: AnsiString;
  I: Integer;
begin
  SysPaletteBin := AnsiHex2Bin(FSysPaletteHex);
  Move(Pointer(SysPaletteBin)^, FSystemPalette, SizeOf(FSystemPalette));
  FSafeGetSysColor := @GetSysColor;
  ReplaceDllFunc(
    Winapi.Windows.user32,
    GetProcAddress(GetModuleHandle(Winapi.Windows.user32), 'GetSysColor'),
    @InterceptGetSysColor,
    GetModuleHandle(nil));

  if InitThemeLibrary then
  begin
    FSafeGetThemeSysColor := GetThemeSysColor;
    GetThemeSysColor := InterceptGetThemeSysColor;
  end;

  for I := 0 to High(FSystemBrushes) do
    FSystemBrushes[I] := CreateSolidBrush(FSystemPalette[I]);
  ReplaceDllFunc(
    Winapi.Windows.user32,
    GetProcAddress(GetModuleHandle(Winapi.Windows.user32), 'GetSysColorBrush'),
    @InterceptGetSysColorBrush,
    GetModuleHandle(nil));

end;

function GetSystemPaletteAsHex: AnsiString;
var
  SystemPalette: TSystemPalette;
begin
  SystemPalette := GetSystemPalette;
  SetLength(Result, SizeOf(SystemPalette));
  Move(SystemPalette, Pointer(Result)^, SizeOf(SystemPalette));
  Result := AnsiBin2Hex(Result);
end;

initialization
  InterceptPalette;
end.