x64 Reflective DLL Injector (translate C++ to Delphi)

I need an x64 Reflective DLL Injector written in Delphi.

I found a C version that works fine (compiled with DevC++ with 64bit app support). I made a Delphi version that compiles fine and without any syntax error, but when it executes then the target application crashes.

In my tests, I discovered that inside of the AdjustPE() function, if I try to execute another function (ie Test;) or declare a string variable and initialize it (ie, S := ''), the crash occurs. This also happens in the original C code with a printf(""); function call, for example.

What am I missing? Following is the C code and Delphi code:

C

#include <stdio.h>
#include <windows.h>
#include <tlhelp32.h>
#include <string.h>

typedef struct _PE_INFO
{
    LPVOID base;
    BOOL reloc;
    LPVOID Get_Proc;
    LPVOID Load_DLL;
}PE_INFO, * LPE_INFO;

LPVOID Read_In_Memory(char* FileName)
{
    HANDLE f, h;
    LPVOID mem;
    
    if((f = CreateFileA(FileName, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL)) == INVALID_HANDLE_VALUE)
    return NULL;
    
    if((h = CreateFileMappingA(f, NULL, PAGE_READONLY, 0, 0, NULL)) == NULL)
    return NULL;
    
    if((mem = MapViewOfFile(h, FILE_MAP_READ, 0, 0, 0)) == NULL)
    return NULL;
    else
    return mem;
}

HANDLE Find_Process(char * process_name)
{
    HANDLE snap, proc;
    PROCESSENTRY32 ps;
    BOOL found = 0;
    
    ps.dwSize = sizeof(ps);
    
    if((snap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)) == INVALID_HANDLE_VALUE)
    return NULL;
    
    if(!Process32First(snap, &ps))
    return NULL;
    
    do
    {
        if(!strcmp(process_name, ps.szExeFile))
        {
            found = 1;
            break;
        }
        
    }while (Process32Next(snap, &ps));
    
    CloseHandle(snap);
    
    if(!found)
    return NULL;
    
    if((proc = OpenProcess(PROCESS_ALL_ACCESS, 0, ps.th32ProcessID)) == NULL)
    {
        return NULL;
    }
    else
        return proc;
}

void AdjustPE(LPE_INFO pe)
{
    PIMAGE_DOS_HEADER dos;
    PIMAGE_NT_HEADERS nt;
    LPVOID base;
    PIMAGE_IMPORT_DESCRIPTOR import;
    PIMAGE_THUNK_DATA Othunk, Fthunk;
    PIMAGE_BASE_RELOCATION reloc;
    PIMAGE_TLS_DIRECTORY tls;
    PIMAGE_TLS_CALLBACK * CallBack;
    ULONGLONG *p, delta;
    
    BOOL(*Dll_Entry)(LPVOID, DWORD, LPVOID);
    LPVOID(*Load_DLL)(LPSTR);
    LPVOID(*Get_Proc)(LPVOID, LPSTR);
    
    base = pe->base;
    Load_DLL = pe->Load_DLL;
    Get_Proc = pe->Get_Proc;
    
    dos = (PIMAGE_DOS_HEADER)base;
    nt = (PIMAGE_NT_HEADERS)(base + dos->e_lfanew);
    
    Dll_Entry = base + nt->OptionalHeader.AddressOfEntryPoint;
    
    if(!pe->reloc)
    goto Load_Import;
    
    Base_Relocation:
        if(nt->OptionalHeader.DataDirectory[5].VirtualAddress == 0)
        goto Load_Import;
        
        delta = (ULONGLONG)base + nt->OptionalHeader.ImageBase;
        reloc = (PIMAGE_BASE_RELOCATION)(base + nt->OptionalHeader.DataDirectory[5].VirtualAddress); 
        
        while(reloc->VirtualAddress)
        {
            LPVOID dest = base + reloc->VirtualAddress;
            int nEntry = (reloc->SizeOfBlock - sizeof(IMAGE_BASE_RELOCATION)) / 2; 
            PDWORD data = (PDWORD)((LPVOID)reloc + sizeof(IMAGE_BASE_RELOCATION));
            int i;
            
            for(i = 0; i < nEntry; data++)
            {
                if(((*data) >> 12) == 10)
                {
                  p = (PULONGLONG)(dest + ((*data)&0xfff));
                  *p += delta;  
                }
            }
            
            reloc = (PIMAGE_BASE_RELOCATION)((LPVOID)reloc + reloc->SizeOfBlock);
        }
        
        Load_Import:
            if(nt->OptionalHeader.DataDirectory[1].VirtualAddress == 0)
            goto TLS_CallBack;
            
            import = (PIMAGE_IMPORT_DESCRIPTOR)(base + nt->OptionalHeader.DataDirectory[1].VirtualAddress);
            
            while(import->Name)
            {
                LPVOID dll = (*Load_DLL)(base + import->Name);
                Othunk = (PIMAGE_THUNK_DATA)(base + import->OriginalFirstThunk);
                Fthunk = (PIMAGE_THUNK_DATA)(base + import->FirstThunk);
            
            if(!import->OriginalFirstThunk)
            Othunk = Fthunk;
            
            while(Othunk->u1.AddressOfData)
            {
                if(Othunk->u1.Ordinal & IMAGE_ORDINAL_FLAG)
                {
                    *(ULONGLONG*) Fthunk = (ULONGLONG)(*Get_Proc)(dll, (LPSTR)IMAGE_ORDINAL(Othunk->u1.Ordinal));
                }
                else
                {
                    PIMAGE_IMPORT_BY_NAME fnm = (PIMAGE_IMPORT_BY_NAME)(base + Othunk->u1.AddressOfData);
                    *(PULONGLONG) Fthunk = (ULONGLONG)(*Get_Proc)(dll, fnm->Name);
                }
                Othunk++;
                Fthunk++;
            }
            import++;
          }
            
            TLS_CallBack:
                if(nt->OptionalHeader.DataDirectory[9].VirtualAddress == 0)
                goto Execute_Entry;
                
                tls = (PIMAGE_TLS_DIRECTORY)(base + nt->OptionalHeader.DataDirectory[9].VirtualAddress);
                
                if(tls->AddressOfCallBacks == 0)
                goto Execute_Entry;
                
                CallBack = (PIMAGE_TLS_CALLBACK*)(tls->AddressOfCallBacks);
                
                while(*CallBack)
                {
                    (*CallBack)(base, DLL_PROCESS_ATTACH, NULL);
                    CallBack++;
                }
                
                
            Execute_Entry:
                (*Dll_Entry)(base, DLL_PROCESS_ATTACH, NULL);
}

int main(int i, char **arg) 
{
    if(i != 2)
    {
        printf("Usage %s <pe>", *arg);
        return 0;
    }
    
    HANDLE proc;
    LPVOID base, Rbase, Adj;
    PIMAGE_DOS_HEADER dos;
    PIMAGE_SECTION_HEADER sec;
    PIMAGE_NT_HEADERS nt;
    DWORD Func_Size;
    PE_INFO pe;
    
    printf("[+] Opening file...\n");
    
    if((base = Read_In_Memory("Project1.dll"/**(arg + 1)*/)) == NULL)
    {
        printf("[-] File I/O Error %s", *(arg + 1));
        return 0;
    }
    
    dos = (PIMAGE_DOS_HEADER)base;
    
    if(dos->e_magic != 23117)
    {
        printf("[-] Invalid file");
        return 0;
    }
    
    nt = (PIMAGE_NT_HEADERS)(base + dos->e_lfanew);
    sec = (PIMAGE_SECTION_HEADER)((LPVOID)nt + 24 + nt->FileHeader.SizeOfOptionalHeader);
    
    if(nt->OptionalHeader.Magic != IMAGE_NT_OPTIONAL_HDR64_MAGIC)
    {
        printf("[-] This is not 64 bit pe");
        return 0;
    }
    
    printf("[+] Open process...");
    
    if((proc = Find_Process("notepad.exe")) == NULL)
    {
        printf("[-] Failed to open process");
        return 0;
    }
    
    printf("\n[+] Allocating memory into remote process");
    
    pe.reloc = 0;
    
    if((Rbase = VirtualAllocEx(proc, (LPVOID)nt->OptionalHeader.ImageBase, nt->OptionalHeader.SizeOfImage, MEM_COMMIT | MEM_RESERVE, PAGE_EXECUTE_READWRITE)) == NULL)
    {
        printf("\n[!] Failed to allocate memory at %#p\n[!] Trying alternative\n", nt->OptionalHeader.ImageBase);
        pe.reloc = 1;
        
        if((Rbase = VirtualAllocEx(proc, NULL, nt->OptionalHeader.SizeOfImage, MEM_COMMIT | MEM_RESERVE, PAGE_EXECUTE_READWRITE)) == NULL)
        {
            printf("[-] Failed to allocate memory into remote process");
            return 0;
        }
    }
    
    printf("\n[+] Copying headers...");
    WriteProcessMemory(proc, Rbase, base, nt->OptionalHeader.SizeOfHeaders, NULL);
    printf("\n[+] Copying sections...");
    
    for(i = 0; i < nt->FileHeader.NumberOfSections; i++)
    {
        WriteProcessMemory(proc, Rbase + sec->VirtualAddress, base + sec->PointerToRawData, sec->SizeOfRawData, NULL);
        sec++;
    }
    
    Func_Size = (DWORD)((ULONGLONG)main - (ULONGLONG)AdjustPE);
    pe.base = Rbase;
    pe.Get_Proc = GetProcAddress;
    pe.Load_DLL = LoadLibraryA;
    
    if((Adj = VirtualAllocEx(proc, NULL, Func_Size + sizeof(pe), MEM_COMMIT | MEM_RESERVE, PAGE_EXECUTE_READWRITE)) == NULL)
    {
        printf("\n[-] Failed to allocate memory for PE adjusting");
        VirtualFreeEx(proc, Rbase, 0, MEM_RELEASE);
        return 0;
    }
    
    WriteProcessMemory(proc, Adj, &pe, sizeof(pe), NULL);
    WriteProcessMemory(proc, Adj + sizeof(pe), AdjustPE, Func_Size, NULL);
    
    if(!CreateRemoteThread(proc, NULL, 0, (LPTHREAD_START_ROUTINE)(Adj + sizeof(pe)), Adj, 0, NULL))
    printf("\n[-] Failed to adjust PE");
    else
    printf("\n[+] Adjusting PE and executing...");
        
    return 0;
}

Edition:

I updated Delphi code to an approcah more conventional, and even so, the same problem happens (target application crashes).

Delphi (ReflectiveInjector + ReflectiveDll)

program ReflectiveInjector;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils,
  Classes,
  TlHelp32;

function LoadDllFromFile(const FileName: string; out DllBuffer: Pointer; out DllSize: DWORD): Boolean;
var
  FS: TFileStream;
begin
  Result := False;
  try
    FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
    try
      DllSize := FS.Size;
      GetMem(DllBuffer, DllSize);
      FS.ReadBuffer(DllBuffer^, DllSize);
      Result := True;
    finally
      FS.Free;
    end;
  except
    DllBuffer := nil;
    DllSize := 0;
  end;
end;

function GetProcessIdByName(const ProcName: string): DWORD;
var
  Snapshot: THandle;
  Entry: TProcessEntry32;
begin
  Result := 0;
  Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if Snapshot <> INVALID_HANDLE_VALUE then
  begin
    Entry.dwSize := SizeOf(Entry);
    if Process32First(Snapshot, Entry) then
      repeat
        if SameText(ExtractFileName(Entry.szExeFile), ProcName) then
        begin
          Result := Entry.th32ProcessID;
          Break;
        end;
      until not Process32Next(Snapshot, Entry);
    CloseHandle(Snapshot);
  end;
end;

function ImageFirstSection(ntHeaders: PImageNtHeaders): PImageSectionHeader;
begin
  Result := PImageSectionHeader(NativeUInt(ntHeaders) + SizeOf(TImageNtHeaders) - SizeOf(TImageOptionalHeader) + ntHeaders^.FileHeader.SizeOfOptionalHeader);
end;

function Rva2Offset(RVA: DWORD; BaseAddress: Pointer): DWORD;
var
  NtHeaders: PImageNtHeaders;
  Section: PImageSectionHeader;
  I: Integer;
begin
  NtHeaders := PImageNtHeaders(NativeUInt(BaseAddress) + NativeUInt(PImageDosHeader(BaseAddress)^._lfanew));
  Section := PImageSectionHeader(NativeUInt(NtHeaders) + SizeOf(TImageNtHeaders));
  for I := 0 to NtHeaders^.FileHeader.NumberOfSections - 1 do
  begin
    if (RVA >= Section^.VirtualAddress) and (RVA < Section^.VirtualAddress + Section^.SizeOfRawData) then
    begin
      Result := RVA - Section^.VirtualAddress + Section^.PointerToRawData;
      Exit;
    end;
    Inc(Section);
  end;
  Result := 0;
end;

function GetReflectiveLoaderOffset(lpReflectiveDllBuffer: Pointer; FuncName: string): DWORD;
var
  UiBaseAddress, UiExportDir, UiNameArray, UiAddressArray, UiNameOrdinals: NativeUInt;
  ExportDir: PImageExportDirectory;
  ExportName: PAnsiChar;
  Counter: DWORD;
  OrdinalIndex: Word;
begin
  Result := 0;
  UiBaseAddress := NativeUInt(lpReflectiveDllBuffer);

  UiExportDir := UiBaseAddress + NativeUInt(PImageDosHeader(UiBaseAddress)^._lfanew);
  UiNameArray := NativeUInt(@PImageNtHeaders(UiExportDir)^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT]);

  UiExportDir := UiBaseAddress + Rva2Offset(PImageDataDirectory(UiNameArray)^.VirtualAddress, Pointer(UiBaseAddress));
  ExportDir := PImageExportDirectory(UiExportDir);

  UiNameArray := UiBaseAddress + Rva2Offset(ExportDir^.AddressOfNames, Pointer(UiBaseAddress));
  UiAddressArray := UiBaseAddress + Rva2Offset(ExportDir^.AddressOfFunctions, Pointer(UiBaseAddress));
  UiNameOrdinals := UiBaseAddress + Rva2Offset(ExportDir^.AddressOfNameOrdinals, Pointer(UiBaseAddress));
  Counter := ExportDir^.NumberOfNames;

  while Counter > 0 do
  begin
    ExportName := PAnsiChar(UiBaseAddress + Rva2Offset(PDWORD(UiNameArray)^, Pointer(UiBaseAddress)));

    if Pos(FuncName, string(ExportName)) > 0 then
    begin
      OrdinalIndex := PWORD(UiNameOrdinals)^;
      Result := Rva2Offset(PDWORD(UiAddressArray + OrdinalIndex * SizeOf(DWORD))^, Pointer(UiBaseAddress));
      Exit;
    end;

    Inc(UiNameArray, SizeOf(DWORD));
    Inc(UiNameOrdinals, SizeOf(Word));
    Dec(Counter);
  end;
end;

procedure InjectReflectiveDll(ProcessId: DWORD; DllPath: string);
var
  DosHeader: PImageDosHeader;
  NtHeaders: PImageNtHeaders;
  Section: PImageSectionHeader;
  hProcess, hThread: THandle;
  DllBase, RemoteBase: Pointer;
  ReflectiveRVA, ThreadID, DllSize: DWORD;
  BytesWritten: SIZE_T;
  I: Integer;
begin
  hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, ProcessId);
  if hProcess = 0 then
  begin
    Writeln('Failed to open target process.');
    Exit;
  end;

  if not LoadDllFromFile(DllPath, DllBase, DllSize) then
  begin
    Writeln('Failed to load DLL.');
    Exit;
  end;

  DosHeader := PImageDosHeader(DllBase);
  NtHeaders := PImageNtHeaders(NativeUInt(DllBase) + NativeUInt(DosHeader^._lfanew));

  ReflectiveRVA := GetReflectiveLoaderOffset(DllBase, 'fnReflectiveLoader');
  if ReflectiveRVA = 0 then
  begin
    Writeln('Export fnReflectiveLoader not found.');
    Exit;
  end;

  RemoteBase := VirtualAllocEx(hProcess, Pointer(NtHeaders^.OptionalHeader.ImageBase), NtHeaders^.OptionalHeader.SizeOfImage, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
  if RemoteBase = nil then
  begin
    Writeln('VirtualAllocEx failed.');
    Exit;
  end;

  {
  if not WriteProcessMemory(hProcess, RemoteBase, DllBase, DllSize, BytesWritten) then
  begin
    Writeln('WriteProcessMemory failed.');
    Exit;
  end;
  }
  // Copying headers...
  WriteProcessMemory(hProcess, RemoteBase, DllBase, NtHeaders^.OptionalHeader.SizeOfHeaders, BytesWritten);

  // Copying sections...
  Section := ImageFirstSection(NtHeaders);
  for I := 0 to NtHeaders^.FileHeader.NumberOfSections - 1 do
  begin
    WriteProcessMemory(hProcess, PByte(RemoteBase) + Section^.VirtualAddress, PByte(DllBase) + Section^.PointerToRawData, Section^.SizeOfRawData, BytesWritten);
    Inc(Section);
  end;

  hThread := CreateRemoteThread(hProcess, nil, 0, Pointer(NativeUInt(RemoteBase) + ReflectiveRVA), RemoteBase, 0, ThreadID);
  if hThread = 0 then
    Writeln('CreateRemoteThread failed.')
  else
    Writeln('Injection successful.');
end;

var
  PId: DWORD;

begin
  PId := GetProcessIdByName('notepad.exe');
  if PId = 0 then
  begin
    Writeln('Target process not found.');
    Exit;
  end;
  InjectReflectiveDll(PId, 'ReflectiveLoader.dll');
  Readln;
end.

//=================================================================================================================================================================

library ReflectiveLoader;

uses
  Windows,
  SysUtils,
  uReflectiveLoader;

{$R *.res}

procedure DllMain(AReason: Integer);
var
  AMessage: string;
  AStrReason: string;
begin
  case AReason of
    DLL_PROCESS_DETACH:
      AStrReason := 'DLL_PROCESS_DETACH';
    DLL_PROCESS_ATTACH:
      AStrReason := 'DLL_PROCESS_ATTACH';
    DLL_THREAD_ATTACH:
      AStrReason := 'DLL_THREAD_ATTACH';
    DLL_THREAD_DETACH:
      AStrReason := 'DLL_THREAD_DETACH';
  else
    AStrReason := 'REASON_UNKNOWN';
  end;

  AMessage := Format('(%s): Injected! Living in %d (%s) process.', [AStrReason, GetCurrentProcessId(), ExtractFileName(GetModuleName(0))]);

  MessageBox(0, PWideChar(AMessage), 'Evil DLL', MB_ICONINFORMATION);
end;

exports
  fnReflectiveLoader name 'fnReflectiveLoader';

begin
  DllProc := DllMain;
  DllMain(DLL_PROCESS_ATTACH);
end.

//========================= uReflectiveLoader.pas ==============================

unit uReflectiveLoader;

interface

uses
  Windows;

procedure fnReflectiveLoader(pBase: Pointer); stdcall;

implementation

procedure fnReflectiveLoader(pBase: Pointer); stdcall;
type
  TImageBaseRelocation = packed record
    VirtualAddress: DWORD;
    SizeOfBlock: DWORD;
  end;

  PImageBaseRelocation = ^TImageBaseRelocation;

  TBaseRelocationEntry = packed record
    Offset: Word;
    EntryType: Word;
  end;

  PBaseRelocationEntry = ^TBaseRelocationEntry;
const
  IMAGE_REL_BASED_DIR64 = 10;
var
  DosHeader: PImageDosHeader;
  NtHeaders: PImageNtHeaders;
  RelocDir: TImageDataDirectory;
  RelocBlock: PImageBaseRelocation;
  EntryPtr: PWord;
  Entry: TBaseRelocationEntry;
  Delta: NativeUInt;
  Count, I: Integer;
  Addr: PNativeUInt;
  ImportDesc: PImageImportDescriptor;
  hLib: HMODULE;
  Thunk: PImageThunkData;
  FuncName: PImageImportByName;
  LibName: PAnsiChar;
  DllMain: function(hinstDLL: HMODULE; fdwReason: DWORD; lpvReserved: Pointer): BOOL; stdcall;

  function MakeRelocEntry(Value: Word): TBaseRelocationEntry;
  begin
    Result.Offset := Value and $0FFF;
    Result.EntryType := (Value shr 12) and $000F;
  end;

  function IMAGE_SNAP_BY_ORDINAL(Ordinal: UInt64): Boolean;
  begin
    Result := (Ordinal and IMAGE_ORDINAL_FLAG) <> 0;
  end;

begin
  DosHeader := PImageDosHeader(pBase);
  NtHeaders := PImageNtHeaders(NativeUInt(pBase) + NativeUInt(DosHeader^._lfanew));
  Delta := NativeUInt(pBase) - NtHeaders^.OptionalHeader.ImageBase;
  RelocDir := NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_BASERELOC];
  RelocBlock := PImageBaseRelocation(NativeUInt(pBase) + RelocDir.VirtualAddress);

  while (RelocBlock^.VirtualAddress <> 0) do
  begin
    Count := (RelocBlock^.SizeOfBlock - SizeOf(TImageBaseRelocation)) div SizeOf(Word);
    EntryPtr := PWord(NativeUInt(RelocBlock) + SizeOf(TImageBaseRelocation));
    for I := 0 to Count - 1 do
    begin
      Entry := MakeRelocEntry(EntryPtr^);
      if Entry.EntryType = IMAGE_REL_BASED_DIR64 then
      begin
        Addr := PNativeUInt(NativeUInt(pBase) + RelocBlock^.VirtualAddress + Entry.Offset);
        Inc(Addr^, Delta);
      end;
      Inc(EntryPtr);
    end;
    RelocBlock := PImageBaseRelocation(NativeUInt(RelocBlock) + RelocBlock^.SizeOfBlock);
  end;

  ImportDesc := PImageImportDescriptor(NativeUInt(pBase) + NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress);
  while ImportDesc^.Name <> 0 do
  begin
    LibName := PAnsiChar(NativeUInt(pBase) + ImportDesc^.Name);
    hLib := LoadLibraryA(LibName);
    if hLib <> 0 then
    begin
      Thunk := PImageThunkData(NativeUInt(pBase) + ImportDesc^.FirstThunk);
      while Thunk^.AddressOfData <> 0 do
      begin
        if IMAGE_SNAP_BY_ORDINAL(Thunk^.Ordinal) then
          Thunk^._Function := NativeUInt(GetProcAddress(hLib, PAnsiChar(Thunk^.Ordinal)))
        else
        begin
          FuncName := PImageImportByName(NativeUInt(pBase) + Thunk^.AddressOfData);
          Thunk^._Function := NativeUInt(GetProcAddress(hLib, PAnsiChar(@FuncName^.Name)));
        end;
        Inc(Thunk);
      end;
    end;
    Inc(ImportDesc);
  end;

  DllMain := Pointer(NativeUInt(pBase) + NtHeaders^.OptionalHeader.AddressOfEntryPoint);
  DllMain(HMODULE(pBase), DLL_PROCESS_ATTACH, nil);
end;

end.

In Delphi, the solution was manually resolve LoadLibraryA and GetProcAddress addresses in the remote process by parsing kernel32.dll's export table in the remote process memory.

uses
  Windows,
  SysUtils,
  Classes,
  TlHelp32;

type
  TLoaderParams = packed record
    BaseAddress: Pointer;
    LoadLibraryA: function(lpLibFileName: PAnsiChar): HMODULE stdcall;
    GetProcAddress: function(hModule: hModule; lpProcName: LPCSTR): FARPROC stdcall;
  end;

  PLoaderParams = ^TLoaderParams;

type
  TMemoryModule = record
    BaseAddress: Pointer;
    SizeOfImage: Cardinal;
  end;

type
  TBaseRelocationEntry = packed record
    Offset: Word;
    EntryType: Word;
  end;

  PBaseRelocationEntry = ^TBaseRelocationEntry;

type
  TImageBaseRelocation = packed record
    VirtualAddress: DWORD;
    SizeOfBlock: DWORD;
  end;

  PImageBaseRelocation = ^TImageBaseRelocation;

function GetProcessId(const ProcName: string): DWORD;
var
  hSnap: THandle;
  Pe: TProcessEntry32;
begin
  Result := 0;
  hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if hSnap = INVALID_HANDLE_VALUE then
    Exit;
  Pe.dwSize := SizeOf(Pe);
  if Process32First(hSnap, Pe) then
    repeat
      if SameText(Pe.szExeFile, ProcName) then
      begin
        Result := Pe.th32ProcessID;
        Break;
      end;
    until not Process32Next(hSnap, Pe);
  CloseHandle(hSnap);
end;

function GetRemoteModuleBase(ProcessID: DWORD; ModuleName: string): Pointer;
var
  hSnap: THandle;
  Me: TModuleEntry32;
begin
  Result := nil;
  hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);
  if hSnap = INVALID_HANDLE_VALUE then
    Exit;

  Me.dwSize := SizeOf(Me);
  if Module32First(hSnap, Me) then
  begin
    repeat
      if SameText(ModuleName, Me.szModule) then
      begin
        Result := Me.modBaseAddr;
        Break;
      end;
    until not Module32Next(hSnap, Me);
  end;
  CloseHandle(hSnap);
end;

function GetRemoteProcAddress(hProcess: THandle; hRemoteModule: Pointer; FunctionName: AnsiString): Pointer;
var
  DosHdr: TImageDosHeader;
  NTHeaders: TImageNtHeaders;
  ExportDir: TImageExportDirectory;
  ExportDirRVA, Addr: DWORD;
  Names, Functions: array of DWORD;
  Ordinals: array of Word;
  I: Integer;
  NameBuf: array[0..255] of AnsiChar;
  BytesRead: SIZE_T;
begin
  Result := nil;

  ReadProcessMemory(hProcess, hRemoteModule, @DosHdr, SizeOf(DosHdr), BytesRead);
  if DosHdr.e_magic <> IMAGE_DOS_SIGNATURE then
    Exit;

  ReadProcessMemory(hProcess, Pointer(NativeUInt(hRemoteModule) + NativeUInt(DosHdr._lfanew)), @NTHeaders, SizeOf(NTHeaders), BytesRead);
  if NTHeaders.Signature <> IMAGE_NT_SIGNATURE then
    Exit;

  ExportDirRVA := NTHeaders.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress;
  if ExportDirRVA = 0 then
    Exit;

  ReadProcessMemory(hProcess, Pointer(NativeUInt(hRemoteModule) + ExportDirRVA), @ExportDir, SizeOf(ExportDir), BytesRead);

  SetLength(Names, ExportDir.NumberOfNames);
  SetLength(Ordinals, ExportDir.NumberOfNames);
  SetLength(Functions, ExportDir.NumberOfFunctions);

  ReadProcessMemory(hProcess, Pointer(NativeUInt(hRemoteModule) + ExportDir.AddressOfNames), @Names[0], Length(Names) * SizeOf(DWORD), BytesRead);
  ReadProcessMemory(hProcess, Pointer(NativeUInt(hRemoteModule) + ExportDir.AddressOfNameOrdinals), @Ordinals[0], Length(Ordinals) * SizeOf(Word), BytesRead);
  ReadProcessMemory(hProcess, Pointer(NativeUInt(hRemoteModule) + ExportDir.AddressOfFunctions), @Functions[0], Length(Functions) * SizeOf(DWORD), BytesRead);

  for I := 0 to High(Names) do
  begin
    ReadProcessMemory(hProcess, Pointer(NativeUInt(hRemoteModule) + Names[I]), @NameBuf[0], SizeOf(NameBuf), BytesRead);
    if AnsiString(PAnsiChar(@NameBuf[0])) = FunctionName then
    begin
      Addr := Functions[Ordinals[I]];
      Result := Pointer(NativeUInt(hRemoteModule) + Addr);
      Break;
    end;
  end;
end;

procedure LoadLibraryR(Params: PLoaderParams); stdcall;
const
  IMAGE_REL_BASED_DIR64 = 10;
var
  DosHeader: PImageDosHeader;
  NtHeaders: PImageNtHeaders;
  RelocDir: TImageDataDirectory;
  ImportDesc: PImageImportDescriptor;
  RelocBlock: PImageBaseRelocation;
  Thunk: PImageThunkData;
  FuncName: PImageImportByName;
  Entry: TBaseRelocationEntry;
  EntryPtr: PWord;
  DllMain: function(hinstDLL: HMODULE; fdwReason: DWORD; lpvReserved: Pointer): BOOL stdcall;
  Delta: NativeUInt;
  I, Count: Integer;
  Addr: PNativeUInt;
begin
  DosHeader := PImageDosHeader(Params^.BaseAddress);
  NtHeaders := PImageNtHeaders(NativeUInt(DosHeader) + NativeUInt(DosHeader^._lfanew));

  Delta := NativeUInt(Params^.BaseAddress) - NtHeaders^.OptionalHeader.ImageBase;
  RelocDir := NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_BASERELOC];
  RelocBlock := PImageBaseRelocation(NativeUInt(Params^.BaseAddress) + RelocDir.VirtualAddress);

  while (RelocBlock^.VirtualAddress <> 0) do
  begin
    Count := (RelocBlock^.SizeOfBlock - SizeOf(TImageBaseRelocation)) div SizeOf(Word);
    EntryPtr := PWord(NativeUInt(RelocBlock) + SizeOf(TImageBaseRelocation));
    for I := 0 to Count - 1 do
    begin
      Entry.Offset := EntryPtr^ and $FFF;
      Entry.EntryType := (EntryPtr^ shr 12) and $F;
      if Entry.EntryType = IMAGE_REL_BASED_DIR64 then
      begin
        Addr := PNativeUInt(NativeUInt(Params^.BaseAddress) + RelocBlock^.VirtualAddress + Entry.Offset);
        Addr^ := Addr^ + Delta;
      end;
      EntryPtr := PWord(NativeUInt(EntryPtr) + SizeOf(Word));
    end;
    RelocBlock := PImageBaseRelocation(NativeUInt(RelocBlock) + RelocBlock^.SizeOfBlock);
  end;

  ImportDesc := PImageImportDescriptor(NativeUInt(Params^.BaseAddress) + NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress);
  while ImportDesc^.Name <> 0 do
  begin
    Thunk := PImageThunkData(NativeUInt(Params^.BaseAddress) + ImportDesc^.FirstThunk);
    while Thunk^.AddressOfData <> 0 do
    begin
      if (Thunk^.AddressOfData and IMAGE_ORDINAL_FLAG) <> 0 then
        Thunk^._Function := NativeUInt(Params^.GetProcAddress(Params^.LoadLibraryA(PAnsiChar(NativeUInt(Params^.BaseAddress) + ImportDesc^.Name)), PAnsiChar(Thunk^.AddressOfData and $FFFF)))
      else
      begin
        FuncName := PImageImportByName(NativeUInt(Params^.BaseAddress) + Thunk^.AddressOfData);
        Thunk^._Function := NativeUInt(Params^.GetProcAddress(Params^.LoadLibraryA(PAnsiChar(NativeUInt(Params^.BaseAddress) + ImportDesc^.Name)), PAnsiChar(@FuncName^.Name)));
      end;
      Thunk := PImageThunkData(NativeUInt(Thunk) + SizeOf(TImageThunkData));
    end;
    ImportDesc := PImageImportDescriptor(NativeUInt(ImportDesc) + SizeOf(TImageImportDescriptor));
  end;

  DllMain := Pointer(NativeUInt(Params^.BaseAddress) + NtHeaders^.OptionalHeader.AddressOfEntryPoint);
  DllMain(HMODULE(Params^.BaseAddress), DLL_PROCESS_ATTACH, nil);
end;

procedure LoadLibraryR_End;
begin
end;

function MapFileToMemory(pRawDll: Pointer): TMemoryModule;
var
  DosHeader: PImageDosHeader;
  NtHeaders: PImageNtHeaders;
  SectionHeader: PImageSectionHeader;
  LocalBase: Pointer;
  I: Integer;
begin
  ZeroMemory(@Result, SizeOf(Result));

  DosHeader := PImageDosHeader(pRawDll);
  if DosHeader^.e_magic <> IMAGE_DOS_SIGNATURE then
    Exit;

  NtHeaders := PImageNtHeaders(NativeUInt(pRawDll) + NativeUInt(DosHeader^._lfanew));
  if NtHeaders^.Signature <> IMAGE_NT_SIGNATURE then
    Exit;

  Result.SizeOfImage := NtHeaders^.OptionalHeader.SizeOfImage;
  LocalBase := VirtualAlloc(nil, Result.SizeOfImage, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
  if LocalBase = nil then
    Exit;

  Move(pRawDll^, LocalBase^, NtHeaders^.OptionalHeader.SizeOfHeaders);

  SectionHeader := PImageSectionHeader(NativeUInt(@NtHeaders^.OptionalHeader) + NtHeaders^.FileHeader.SizeOfOptionalHeader);

  for I := 0 to NtHeaders^.FileHeader.NumberOfSections - 1 do
  begin
    Move(PByte(pRawDll)[SectionHeader^.PointerToRawData], PByte(LocalBase)[SectionHeader^.VirtualAddress], SectionHeader^.SizeOfRawData);
    Inc(SectionHeader);
  end;

  Result.BaseAddress := LocalBase;
end;

procedure ManualMapR(const ProcessName, FilePath: string);
var
  PId, ThreadId, DLLSize: DWORD;
  hProcess, hThread: THandle;
  DLLBuf: TBytes;
  MappedFile: TMemoryModule;
  RemoteBase, RemoteStub, RemoteParams, hKernel32Remote, pLoadLibraryA, pGetProcAddress: Pointer;
  StubSize: NativeUInt;
  BytesWritten: SIZE_T;
  LoaderParams: PLoaderParams;
begin
  PId := GetProcessId(ProcessName);
  if PId = 0 then
  begin
    Writeln('Target not found!');
    Exit;
  end;

  hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, PId);

  with TFileStream.Create(FilePath, fmOpenRead or fmShareDenyWrite) do
  try
    DLLSize := Size;
    SetLength(DLLBuf, DLLSize);
    ReadBuffer(DLLBuf[0], DLLSize);
  finally
    Free;
  end;

  MappedFile := MapFileToMemory(DLLBuf);

  RemoteBase := VirtualAllocEx(hProcess, nil, MappedFile.SizeOfImage, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
  if not WriteProcessMemory(hProcess, RemoteBase, MappedFile.BaseAddress, MappedFile.SizeOfImage, BytesWritten) then
    Exit;

  StubSize := NativeUInt(@LoadLibraryR_End) - NativeUInt(@LoadLibraryR);

  RemoteStub := VirtualAllocEx(hProcess, nil, StubSize, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
  if not WriteProcessMemory(hProcess, RemoteStub, @LoadLibraryR, StubSize, BytesWritten) then
    Exit;

  hKernel32Remote := GetRemoteModuleBase(PId, kernel32);
  pLoadLibraryA := GetRemoteProcAddress(hProcess, hKernel32Remote, 'LoadLibraryA');
  pGetProcAddress := GetRemoteProcAddress(hProcess, hKernel32Remote, 'GetProcAddress');

  New(LoaderParams);
  LoaderParams^.BaseAddress := RemoteBase;
  LoaderParams^.LoadLibraryA := pLoadLibraryA;
  LoaderParams^.GetProcAddress := pGetProcAddress;

  RemoteParams := VirtualAllocEx(hProcess, nil, SizeOf(TLoaderParams), MEM_COMMIT or MEM_RESERVE, PAGE_READWRITE);
  if not WriteProcessMemory(hProcess, RemoteParams, LoaderParams, SizeOf(TLoaderParams), BytesWritten) then
    Exit;

  hThread := CreateRemoteThread(hProcess, nil, 0, RemoteStub, RemoteParams, 0, ThreadId);
  if hThread = 0 then
    Writeln('Failed to start thread.')
  else
    Writeln('DLL injected!');

  CloseHandle(hProcess);
end;

begin
  ManualMapR('notepad.exe', 'Project1.dll');
  Readln;
end.