External Program running in different user desktop - delphi

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:
Create two users (user1 and user2)
Logged in to user1 first and then user2
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.