External Program running in different user desktop

Question

I am trying to execute an external program under SYSTEM level and I applied this method (where I only changed the CreateProcessAsSystem('c:\windows\system32\cmd.exe'); to the path of the application I wanted to execute) and it works perfectly as expected only if there is one user logged into the pc.

Eg. I have 2 users (user1 and user2) and both users are logged in (user1 first and then user2). Then, I run the program in user2 and my external program supposed to appear on user2's desktop. However, it appears on user1's desktop. Can I know what causes this to happen and how can I solve this?

Problem reproduction:

1. Create two users (user1 and user2)
2. Logged in to user1 first and then user2
3. Run the program in user2

Code:

TestSystem.pas

unit TestSystem;

interface

uses
  Winapi.WinSvc,
  Vcl.SvcMgr,
  Winapi.Windows,
  System.SysUtils,
  Winapi.TlHelp32,
  System.Classes;

type
  TTestService = class(TService)
    procedure ServiceExecute(Sender: TService);
  private
    lpApplicationName,
    lpCommandLine,
    lpCurrentDirectory: PWideChar;
  public
    function GetServiceController: TServiceController; override;
  end;

procedure CreateProcessAsSystem(const lpApplicationName: PWideChar;
                              const lpCommandLine:PWideChar = nil;
                              const lpCurrentDirectory: PWideChar  = nil);
var
  TestService: TTestService;

implementation

{$R *.dfm}

function WTSQueryUserToken(SessionId: ULONG; var phToken: THandle): BOOL; stdcall; external 'Wtsapi32.dll';


type
  TServiceApplicationEx = class(TServiceApplication)
  end;
  TServiceApplicationHelper = class helper for TServiceApplication
  public
    procedure ServicesRegister(Install, Silent: Boolean);
  end;

function IsUserAnAdmin: BOOL; stdcall; external 'shell32.dll' name 'IsUserAnAdmin';

function CreateEnvironmentBlock(var lpEnvironment: Pointer; hToken: THandle;
                                    bInherit: BOOL): BOOL;
                                    stdcall; external 'Userenv.dll';

function DestroyEnvironmentBlock(pEnvironment: Pointer): BOOL; stdcall; external 'Userenv.dll';


function _GetIntegrityLevel() : DWORD;
type
  PTokenMandatoryLabel = ^TTokenMandatoryLabel;
  TTokenMandatoryLabel = packed record
    Label_ : TSidAndAttributes;
  end;
var
  hToken : THandle;
  cbSize: DWORD;
  pTIL : PTokenMandatoryLabel;
  dwTokenUserLength: DWORD;
begin
  Result := 0;
  dwTokenUserLength := MAXCHAR;
  if OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, hToken) then begin
    pTIL := Pointer(LocalAlloc(0, dwTokenUserLength));
    if pTIL = nil then Exit;
    cbSize := SizeOf(TTokenMandatoryLabel);
    if GetTokenInformation(hToken, TokenIntegrityLevel, pTIL, dwTokenUserLength, cbSize) then
      if IsValidSid( (pTIL.Label_).Sid ) then
        Result := GetSidSubAuthority((pTIL.Label_).Sid, GetSidSubAuthorityCount((pTIL.Label_).Sid )^ - 1)^;
    if hToken <> INVALID_HANDLE_VALUE then
      CloseHandle(hToken);
    LocalFree(Cardinal(pTIL));
  end;
end;

function IsUserAnSystem(): Boolean;
const
  SECURITY_MANDATORY_SYSTEM_RID = $00004000;
begin
  Result := (_GetIntegrityLevel = SECURITY_MANDATORY_SYSTEM_RID);
end;

function StartTheService(Service:TService): Boolean;
var
  SCM: SC_HANDLE;
  ServiceHandle: SC_HANDLE;
begin
  Result:= False;
  SCM:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if (SCM <> 0) then begin
    try
      ServiceHandle:= OpenService(SCM, PChar(Service.Name), SERVICE_ALL_ACCESS);
      if (ServiceHandle <> 0) then begin
        Result := StartService(ServiceHandle, 0, pChar(nil^));
        CloseServiceHandle(ServiceHandle);
      end;
    finally
      CloseServiceHandle(SCM);
    end;
  end;
end;

procedure SetServiceName(Service: TService);
begin
  if Assigned(Service) then begin
    Service.DisplayName := 'Run as system service created ' + DateTimeToStr(Now);
    Service.Name        := 'RunAsSystem' + FormatDateTime('ddmmyyyyhhnnss', Now);
  end;
end;

procedure CreateProcessAsSystem(const lpApplicationName: PWideChar;
                              const lpCommandLine:PWideChar = nil;
                              const lpCurrentDirectory: PWideChar  = nil);
begin
  if not ( IsUserAnAdmin ) then begin
    SetLastError(ERROR_ACCESS_DENIED);
    Exit();
  end;

  if not ( FileExists(lpApplicationName) ) then begin
    SetLastError(ERROR_FILE_NOT_FOUND);
    Exit();
  end;

  if ( IsUserAnSystem ) then begin
    Application.Initialize;
    Application.CreateForm(TTestService, TestService);
    TestService.lpApplicationName  := lpApplicationName;
    TestService.lpCommandLine      := lpCommandLine;
    TestService.lpCurrentDirectory := lpCurrentDirectory;
    SetServiceName(TestService);
    Application.Run;
  end else begin
    Application.Free;
    Application := TServiceApplicationEx.Create(nil);
    Application.Initialize;
    Application.CreateForm(TTestService, TestService);
    SetServiceName(TestService);
    Application.ServicesRegister(True, True);
    try
      StartTheService(TestService);
    finally
      Application.ServicesRegister(False, True);
    end;
  end;
end;

procedure TServiceApplicationHelper.ServicesRegister(Install, Silent: Boolean);
begin
  RegisterServices(Install, Silent);
end;

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  TestService.Controller(CtrlCode);
end;

function TTestService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

function ProcessIDFromAppname32( szExeFileName: string ): DWORD;
var
  Snapshot: THandle;
  ProcessEntry: TProcessEntry32;
begin
  Result := 0;
  szExeFileName := UpperCase( szExeFileName );
  Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if Snapshot <> 0 then
    try
      ProcessEntry.dwSize := Sizeof( ProcessEntry );
      if Process32First( Snapshot, ProcessEntry ) then
        repeat
          if Pos(szExeFileName, UpperCase(ExtractFilename(StrPas(ProcessEntry.szExeFile)))) > 0 then begin
            Result:= ProcessEntry.th32ProcessID;
            break;
          end;
        until not Process32Next( Snapshot, ProcessEntry );
    finally
      CloseHandle( Snapshot );
    end;
end;

function TerminateProcessByID(ProcessID: Cardinal): Boolean;
var
  hProcess : THandle;
begin
  Result := False;
  hProcess := OpenProcess(PROCESS_TERMINATE,False,ProcessID);
  if hProcess > 0 then
    try
      Result := Win32Check(TerminateProcess(hProcess,0));
    finally
      CloseHandle(hProcess);
    end;
end;

procedure TTestService.ServiceExecute(Sender: TService);
var
  hToken, hUserToken: THandle;
  StartupInfo : TStartupInfoW;
  ProcessInfo : TProcessInformation;
  P : Pointer;
begin
  if not WTSQueryUserToken(WtsGetActiveConsoleSessionID, hUserToken) then exit;

  if not OpenProcessToken(OpenProcess(PROCESS_ALL_ACCESS, False,
                             ProcessIDFromAppname32('winlogon.exe')),
                             MAXIMUM_ALLOWED,
                             hToken) then exit;

  if CreateEnvironmentBlock(P, hUserToken, True) then begin
    ZeroMemory(@StartupInfo, sizeof(StartupInfo));
    StartupInfo.lpDesktop := ('winsta0\default');
    StartupInfo.wShowWindow := SW_SHOWNORMAL;
    if CreateProcessAsUser(hToken, lpApplicationName, lpCommandLine, nil, nil, False,
                CREATE_UNICODE_ENVIRONMENT, P, lpCurrentDirectory, StartupInfo, ProcessInfo) then begin

    end;
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
    DestroyEnvironmentBlock(P);
  end;

  CloseHandle(hToken);
  CloseHandle(hUserToken);

  TerminateProcessByID(GetCurrentProcessId);
end;

end.

TestProcess.dpr

program TestProcess;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  Winapi.Windows,
  Winapi.TlHelp32,
  Winapi.Shlobj,
  Winapi.ShellApi,
  TestSystem in 'TestSystem.pas' {TestService: TService};

{$region 'Functions to show process''s thread window'}
function EnumWindowsCallback(Handle: HWND; lParam: Integer): BOOL; stdcall;
var
  WID, PID: Integer;
  Text: PWideChar;
  Placement: TWindowPlacement;
begin
  WID := 0;
  PID := lParam;
  GetWindowThreadProcessId(Handle, @WID);
  if (PID = WID) and IsWindowVisible(Handle) then begin
    ShowWindow(Handle, SW_MINIMIZE);
    ShowWindow(Handle, SW_SHOWNORMAL);
    var test := SetForegroundWindow(Handle);
    OutputDebugString(PWideChar(BoolToStr(test, true)));
    FlashWindow(Handle, True);
    GetWindowText(Handle, Text, 150);
    WriteLn('Window ' + Text + ' showed.');
    Result := False;
  end;
  Result := True;
end;

function ShowProcessWindow(PID: Integer): Boolean;
begin
  Result := EnumWindows(@EnumWindowsCallback, LPARAM(PID));
end;
{$endregion}

{$region 'Function to kill process'}
procedure KillProcessWithID(PID: Integer);
begin
  var handle := OpenProcess(PROCESS_TERMINATE, false, PID);
  if handle > 0 then begin
    TerminateProcess(handle, 0);
    CloseHandle(handle);
  end;
end;
{$endregion}

{$region 'Function to search for process using process name'}
function processExists(exeFileName: string; out PID: Integer): Boolean;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  Result := False;
  while Integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
      UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
      UpperCase(ExeFileName))) then
    begin
      PID := FProcessEntry32.th32ProcessID;
      Result := True;
    end;
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapshotHandle);
end;
{$endregion}

var
  ID: Integer;
  Ok: Boolean;
  Input: string;

begin
  try
    repeat
      Write('Enter a process name to check: ');
      ReadLn(Input);
      ID := 0;
      Ok := processExists(Input, ID);

      {$region 'Display process information'}
      WriteLn('');
      WriteLn('Process ' + Input + ' exists --> ' + BoolToStr(Ok, True) + ' --> ' + IntToStr(ID));
      WriteLn('');
      {$endregion}

      {$region 'Show process'}
      if IsUserAnAdmin and (ID > 0) then begin
        WriteLn('Attempt to show process''s thread window...');
        ShowProcessWindow(ID);
      end else if not IsUserAnAdmin then
        WriteLn('Require elevated privilege to show process''s thread window.');
      {$endregion}

      {$region 'Kill process'}
      if (ID > 0) and IsUserAnAdmin then begin
        var reply := '';
        repeat
          Write('Kill process ' + Input + ' (' + IntToStr(ID) + ')? ');
          ReadLn(reply);
        until (reply.ToLower = 'y') or (reply.ToLower = 'n');

        if reply.ToLower = 'y' then KillProcessWithID(ID);
      end else if not IsUserAnAdmin then
        WriteLn('Require elevated privilege to kill process.');
      {$endregion}
    until Input = '';
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

Main.dpr

program Main;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils, System.IOUtils, TestSystem, Vcl.Forms;

var
  path: string;

begin
  path := TPath.Combine(TPath.GetDirectoryName(Application.ExeName), 'TestProcess.exe');
  CreateProcessAsSystem(PWideChar(path));
end.