unit ShellExtFix;
interface
implementation
uses
  Windows,CommDlg,SysUtils,Dialogs;

const
  commdlg32='comdlg32.dll';
  kernel32='kernel32.dll';
  ole32='ole32.dll';
  ValidCompanyName='Microsoft Corporation';

var
  FGetOpenFileNameA:Pointer;
  FGetSaveFileNameA:Pointer;

{++++++++++++AsmUtils.pas++++++++++++}
function WriteCode(Addr:Pointer; const Buffer; Size:DWORD):Boolean;
var
  Writed:DWORD;
begin
  Result:=WriteProcessMemory(GetCurrentProcess,Addr,@Buffer,Size,Writed)and(Writed=Size);
  FlushInstructionCache(GetCurrentProcess,Addr,Size);
end;

function ReadCode(Addr:Pointer; var Buffer; Size:DWORD):Boolean;
var
  Readed:DWORD;
begin
  Result:=ReadProcessMemory(GetCurrentProcess,Addr,@Buffer,Size,Readed)and(Readed=Size);
end;

function GetImageDirectoryEntryAddr(Module:HMODULE; DirectoryEntry:Word; out ASize:DWORD):Pointer; overload;
var
  P:Pointer;
  DosHeader:TImageDosHeader;
  NtHeaders:TImageNtHeaders;
begin
  Result:=nil;
  if DirectoryEntry>=IMAGE_NUMBEROF_DIRECTORY_ENTRIES then Exit;
  P:=Pointer(Module);
  if not ReadCode(P,DosHeader,SizeOf(DosHeader))or(DosHeader.e_magic<>$5A4D) then Exit;
  Inc(PByte(P),DosHeader._lfanew);
  if not ReadCode(P,NtHeaders,SizeOf(NtHeaders)-SizeOf(NtHeaders.OptionalHeader))or(NtHeaders.Signature<>$4550) then Exit;
  with NtHeaders.FileHeader do
    if (SizeOfOptionalHeader<=0)or(SizeOfOptionalHeader>SizeOf(NtHeaders.OptionalHeader)) then Exit;
  Inc(PByte(P),SizeOf(NtHeaders)-SizeOf(NtHeaders.OptionalHeader));
  FillChar(NtHeaders.OptionalHeader,SizeOf(NtHeaders.OptionalHeader),0);
  if not ReadCode(P,NtHeaders.OptionalHeader,NtHeaders.FileHeader.SizeOfOptionalHeader) then Exit;
  if DirectoryEntry>=NtHeaders.OptionalHeader.NumberOfRvaAndSizes then Exit;
  with NtHeaders.OptionalHeader.DataDirectory[DirectoryEntry] do
    if VirtualAddress<>0 then begin
      Result:=Pointer(VirtualAddress+Module);
      ASize:=Size;
    end;
end;

function ReplaceImportEntries(Instance:HMODULE; ModuleName:PChar; OldProc,NewProc:Pointer):Integer;
type
  TIMAGE_IMPORT_DESCRIPTOR=record
    Union:DWORD;
    TimeDateStamp:DWORD;
    ForwarderChain:DWORD;
    Name:DWORD;
    FirstThunk:DWORD;
  end;
var
  Size:DWORD;
  ppfn:PPointer;
  ImportDesc:^TIMAGE_IMPORT_DESCRIPTOR;
begin
  Result:=0;
  if (OldProc=nil)or(Instance=0) then Exit;
  ImportDesc:=GetImageDirectoryEntryAddr(Instance,IMAGE_DIRECTORY_ENTRY_IMPORT,Size);
  if ImportDesc=nil then Exit;
  while ImportDesc.Name<>0 do begin
    if (ModuleName=nil)or(lstrcmpi(ModuleName,PChar(Instance+ImportDesc.Name))=0) then begin
      ppfn:=Pointer(Instance+ImportDesc.FirstThunk);
      while ppfn^<>nil do begin
        if (ppfn^=OldProc)and WriteProcessMemory(GetCurrentProcess,ppfn,@NewProc,SizeOf(NewProc),Size)and(Size=SizeOf(NewProc)) then
          Inc(Result);
        Inc(ppfn);
      end;
    end;
    Inc(ImportDesc);
  end;
end;
{------------AsmUtils.pas------------}

function GetVerValue(const FileName,Value:string):string;
var
  FBuffer:PChar;
  FSize,B:Integer;
  FHandle:DWORD;
  szName:string;
  V:Pointer;
  Len:UINT;
  P:PInteger;
  Buf:array[0..MAX_PATH] of Char;
begin
  Result:='';
  GetShortPathName(PChar(FileName),@Buf,SizeOf(Buf));
  FSize:=GetFileVersionInfoSize(@Buf,FHandle);
  if FSize>0 then begin
    GetMem(FBuffer,FSize);
    try
      if GetFileVersionInfo(@Buf,FHandle,FSize,FBuffer) then begin
        VerQueryValue(FBuffer,'\VarFileInfo\Translation',Pointer(P),Len);
        B:=MakeLong(HiWord(LongInt(P^)),LoWord(LongInt(P^)));
        szName:='\StringFileInfo\'+IntToHex(B,8)+'\'+Value;
        if VerQueryValue(FBuffer,PChar(szName),V,Len) then begin
          SetString(szName,PChar(V),Len);
          Result:=PChar(szName);
        end;
      end;
    finally
      FreeMem(FBuffer);
    end;
  end;
end;

function _LoadLibraryExW(lpFileName:PWideChar; hFile,dwFlags:DWORD):HMODULE; stdcall;
begin
  if GetVerValue(lpFileName,'CompanyName')=ValidCompanyName then
    Result:=LoadLibraryExW(lpFileName,hFile,dwFlags)
  else begin
    Result:=0;
    SetLastError(ERROR_ACCESS_DENIED);
  end;
end;

function SafeCallDialogProc(Proc:Pointer; Param:Pointer):Bool;
type
  TDialogProc=function(Param:Pointer):Bool; stdcall;
var
  OleLib:HMODULE;
  LoadLibProc:Pointer;
begin
  OleLib:=GetModuleHandle(ole32);
  LoadLibProc:=GetProcAddress(GetModuleHandle(kernel32),'LoadLibraryExW');
  ReplaceImportEntries(OleLib,kernel32,LoadLibProc,@_LoadLibraryExW);
  try
    Result:=TDialogProc(Proc)(Param);
  finally
    ReplaceImportEntries(OleLib,kernel32,@_LoadLibraryExW,LoadLibProc);
  end;
end;

function _GetOpenFileNameA(Param:Pointer):Bool; stdcall;
begin
  Result:=SafeCallDialogProc(FGetOpenFileNameA,Param);
end;

function _GetSaveFileNameA(Param:Pointer):Bool; stdcall;
begin
  Result:=SafeCallDialogProc(FGetSaveFileNameA,Param);
end;

procedure PatchDialogProcs;
var
  MainLib,ComDlgLib:HMODULE;
begin
  MainLib:=FindHInstance(TCommonDialog);
  ComDlgLib:=GetModuleHandle(commdlg32);
  FGetOpenFileNameA:=GetProcAddress(ComDlgLib,'GetOpenFileNameA');
  FGetSaveFileNameA:=GetProcAddress(ComDlgLib,'GetSaveFileNameA');
  ReplaceImportEntries(MainLib,commdlg32,FGetOpenFileNameA,@_GetOpenFileNameA);
  ReplaceImportEntries(MainLib,commdlg32,FGetSaveFileNameA,@_GetSaveFileNameA);
end;

initialization
  PatchDialogProcs;
end.