unit Synchronizer;

interface
uses
 Windows, Classes, SysUtils, libWinApi, Messages, SyncObjs;

type

 PSyncRec = ^TSyncRec;
 TSyncRec = record
   idCaller: Cardinal;
   idTarget: Cardinal;
   hCaller: THandle;
   hTarget: THandle;
   ctxTarget: TContext;
   Lock: TRTLCriticalSection;
   RefCount: Integer;
   function AddRef: Integer;
   function Release: Integer;
 end;

 TSynchronizer = class(TThread)
 private
   FSyncList: TList;
   FSyncListLock: TCriticalSection;
 protected
   function CreateSync(idTarget: Cardinal): PSyncRec;
   procedure BeginSync(SR: PSyncRec);
   function FindSync(idTarget: Cardinal): PSyncRec;
   procedure EndSync(SR: PSyncRec);
   procedure FreeSync(SR: PSyncRec);
   procedure DoSync(SR: PSyncRec; Flag: PCardinal);
   procedure DoSyncEnd(idTarget: Cardinal; Flag: PCardinal);
   function LockTargetThreadSync(idTarget: Cardinal): PSyncRec;
   procedure UnlockTargetThreadSync(idTarget: Cardinal);
   function ProcessMessages: Boolean;
   function ProcessMessage(var Msg: TMsg): Boolean;
   procedure Execute; override;
   procedure Quit;
   procedure SyncListLock;
   procedure SyncListUnlock;
 public
   constructor Create;
   destructor Destroy; override;

   function Sync(TargetThreadID: Cardinal): Boolean;
   procedure SyncEnd;
   procedure Post(Msg, Param1, Param2: Integer);
 end;
 

function InjectThread(TargetThreadID: Cardinal): Boolean;
procedure LeaveThread;
 

implementation

const
 WM_MYSYNC = WM_USER + 1;
 WM_MYSYNCEND = WM_USER + 2;

var
 Sync: TSynchronizer;

function InjectThread(TargetThreadID: Cardinal): Boolean;
begin
 if (TargetThreadID <> GetCurrentThreadId) then
   Result := Sync.Sync(TargetThreadID)
 else
   Result := True;
end;

procedure LeaveThread;
begin
 Sync.SyncEnd;
end;
 
 
{ TSynchronizer }

procedure TSynchronizer.BeginSync(SR: PSyncRec);
begin
 SyncListLock;
 try
   SR.hCaller := OpenThread(THREAD_ALL_ACCESS, False, SR.idCaller);
   SR.hTarget := OpenThread(THREAD_ALL_ACCESS, False, SR.idTarget);
 finally
   SyncListUnlock;
 end;
end;

constructor TSynchronizer.Create;
begin
 inherited Create(True);
 FSyncList := TList.Create;
 FSyncListLock := TCriticalSection.Create;
 Resume;
end;

function TSynchronizer.CreateSync(idTarget: Cardinal): PSyncRec;
begin
 SyncListLock;
 try
   Result := AllocMem(SizeOf(Result^));
   Result.idTarget := idTarget;
   Result.Lock.Initialize;
   FSyncList.Add(Result);
 finally
   SyncListUnlock;
 end;
end;

destructor TSynchronizer.Destroy;
begin
 SyncListLock;
 SyncListUnlock;
 FSyncListLock.Free;
 FSyncList.Free;
 inherited;
end;

procedure TSynchronizer.DoSync(SR: PSyncRec; Flag: PCardinal);
var
 ctxCaller: TContext;
begin
 BeginSync(SR);
 SuspendThread(SR.hCaller);
 SuspendThread(SR.hTarget);
 SR.ctxTarget.ContextFlags := CONTEXT_FULL;
 GetThreadContext(SR.hTarget, SR.ctxTarget);
 ctxCaller.ContextFlags := CONTEXT_FULL;
 GetThreadContext(SR.hCaller, ctxCaller);

 SetThreadContext(SR.hTarget, ctxCaller);
 Flag^ := 1;
 PostThreadMessage(SR.idTarget, WM_USER, 0, 0);
 ResumeThread(SR.hTarget);
end;

procedure TSynchronizer.DoSyncEnd(idTarget: Cardinal; Flag: PCardinal);
var
 sr: PSyncRec;
 ctxTmp: TContext;
begin
 sr := FindSync(idTarget);
 SuspendThread(sr.hTarget);
 ctxTmp.ContextFlags := CONTEXT_FULL;
 GetThreadContext(sr.hTarget, ctxTmp);
 SetThreadContext(sr.hTarget, sr.ctxTarget);
 SetThreadContext(sr.hCaller, ctxTmp);
 Flag^ := 1;
 ResumeThread(sr.hTarget);
 ResumeThread(sr.hCaller);
 EndSync(sr);
 UnlockTargetThreadSync(sr.idTarget);
end;

procedure TSynchronizer.EndSync(SR: PSyncRec);
begin
 SyncListLock;
 try
   CloseHandle(SR.hCaller);
   CloseHandle(SR.hTarget);
   SR.hCaller := 0;
   SR.hTarget := 0;
   FillChar(SR.ctxTarget, SizeOf(SR.ctxTarget), 0);
   SR.idCaller := 0;
 finally
   SyncListUnlock;
 end;
end;

procedure TSynchronizer.Execute;
var
 msg: TMsg;
begin
 PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
 while ProcessMessages and WaitMessage do;
end;

function TSynchronizer.FindSync(idTarget: Cardinal): PSyncRec;
var
 i: Integer;
begin
 SyncListLock;
 try
   for i := 0 to FSyncList.Count - 1 do
   begin
     Result := FSyncList[i];
     if (Result.idTarget = idTarget) then
       Exit;
   end;
 finally
   SyncListUnlock;
 end;
 Result := nil;
end;

procedure TSynchronizer.FreeSync(SR: PSyncRec);
begin
 SyncListLock;
 try
   FSyncList.Remove(SR);
   SR.Lock.Destroy;
   FreeMem(SR);
 finally
   SyncListUnlock;
 end;
end;

function TSynchronizer.LockTargetThreadSync(idTarget: Cardinal): PSyncRec;
begin
 SyncListLock;
 try
   Result := FindSync(idTarget);
   if (Result = nil) then
     Result := CreateSync(idTarget);
   Result.AddRef;
 finally
   SyncListUnlock;
 end;
 Result.Lock.Enter;
end;

procedure TSynchronizer.Post(Msg, Param1, Param2: Integer);
begin
 PostThreadMessage(ThreadID, Msg, Param1, Param2);
end;

function TSynchronizer.ProcessMessage(var Msg: TMsg): Boolean;
begin
 Result := True;
 case Msg.message of
   WM_MYSYNC:
     DoSync(Pointer(Msg.lParam), Pointer(Msg.wParam));
   WM_MYSYNCEND:
     DoSyncEnd(Msg.lParam, Pointer(Msg.wParam));
   WM_QUIT:
     Result := False;
 end;
end;

function TSynchronizer.ProcessMessages: Boolean;
var
 item: TMsg;
begin
 Result := True;
 while Result and PeekMessage(item, 0, 0, 0, PM_REMOVE) do
   Result := ProcessMessage(item);
end;

...

procedure TSynchronizer.Quit;
begin
 Post(WM_QUIT, 0, 0);
 WaitFor;
end;

function TSynchronizer.Sync(TargetThreadID: Cardinal): Boolean;
var
 flag: Cardinal;
 sr: PSyncRec;
begin
 Result := True;
 sr := LockTargetThreadSync(TargetThreadID);
 sr.idCaller := GetCurrentThreadId;
 flag := 0;
 Post(WM_MYSYNC, Integer(@flag), Integer(sr));
 while (flag = 0) do;
 if (sr <> nil) then;
end;

procedure TSynchronizer.SyncEnd;
var
 flag: Cardinal;
begin
 flag := 0;
 Post(WM_MYSYNCEND, Integer(@flag), GetCurrentThreadId);
 while (flag = 0) do;
end;

procedure TSynchronizer.SyncListLock;
begin
 FSyncListLock.Enter;
end;

procedure TSynchronizer.SyncListUnlock;
begin
 FSyncListLock.Leave;
end;

procedure TSynchronizer.UnlockTargetThreadSync(idTarget: Cardinal);
var
 sr: PSyncRec;
begin
 SyncListLock;
 try
   sr := FindSync(idTarget);
   sr.Lock.Leave;
   if (sr.Release = 0) then
     FreeSync(sr);
 finally
   SyncListUnlock;
 end;
end;

{ TSyncRec }

function TSyncRec.AddRef: Integer;
begin
 Result := InterlockedIncrement(RefCount);
end;

function TSyncRec.Release: Integer;
begin
 Result := InterlockedDecrement(RefCount);
end;

initialization
 Sync := TSynchronizer.Create;

finalization
 Sync.Quit;
 Sync.Free;

end.

 TMyThread = class(TThread)
 protected
   procedure Execute; override;
 end;

{ TMyThread }

procedure TMyThread.Execute;
begin
 InjectThread(MainThreadID);
 try
   if (GetCurrentThreadId = MainThreadID) then
   begin
     MessageBox(Form1.Handle, 'Work!!!', nil, 0);
     //Logger.LogText('', 'Injected code');
   end;
 finally
   LeaveThread;
 end;
end;

{ TForm1 }

procedure TForm1.Button3Click(Sender: TObject);
var
 t: TMyThread;
begin
 t := TMyThread.Create(True);
 t.FreeOnTerminate := True;
 t.Resume;
end;

const
 THREAD_ALL_ACCESS                 = $1F03FF;

function OpenThread(
 dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwThreadId: DWORD): THandle; stdcall;
function OpenThread; external kernel32 name 'OpenThread';