unit Unit1;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  SvcMgr,
  Dialogs,
  Psapi,
  ExtCtrls,
  ShlObj,
  ComObj,
  ActiveX,
  Registry,
  ShellAPI;

const
  PI_NOUI = 1;


type
  WTS_INFO_CLASS = (WTSInitialProgram,
    WTSApplicationName,
    WTSWorkingDirectory,
    WTSOEMId,
    WTSSessionId,
    WTSUserName,
    WTSWinStationName,
    WTSDomainName,
    WTSConnectState,
    WTSClientBuildNumber,
    WTSClientName,
    WTSClientDirectory,
    WTSClientProduct,
    WTSClientHardwareId,
    WTSClientAddress,
    WTSClientDisplay,
    WTSClientProtocolType);

  _WTS_CONNECTSTATE_CLASS = (WTSActiveWTSActive, WTSConnected, WTSConnectQuery,
    WTSShadow, WTSDisconnected, WTSIdle, WTSListen,
    WTSReset, WTSDown, WTSInit);
  SessionInfo = ^_WTS_SESSION_INFO;
  _WTS_SESSION_INFO = record
    SessionId: DWord;
    pWinStationName: PChar;
    State: _WTS_CONNECTSTATE_CLASS;
  end;
  pDWord = ^DWord;
  MySessionInfo = array of SessionInfo;
  ppSessionInfo = ^MySessionInfo;
    //pHandle=^THandle;

  PProfileInfo = ^TProfileInfo;
  TProfileInfo = packed record
    dwSize: DWORD;
    dwFlags: DWORD;
    lpUserName: PAnsiChar;
    lpProfilePath: PAnsiChar;
    lpDefaultPath: PAnsiChar;
    lpServerName: PAnsiChar;
    lpPolicyPath: PAnsiChar;
    hProfile: THandle;
  end;

  PProfileInfoW = ^TProfileInfoW;
  TProfileInfoW = packed record
    dwSize: DWORD;
    dwFlags: DWORD;
    lpUserName: PWideChar;
    lpProfilePath: PWideChar;
    lpDefaultPath: PWideChar;
    lpServerName: PWideChar;
    lpPolicyPath: PWideChar;
    hProfile: THandle;
  end;



type
  TService1 = class(TService)
    Timer1: TTimer;
    //Timer1: TTimer;
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }

  public
    procedure RunFile(h: THandle; AppName, FileName: string);
    function FindExec(const h: HKEY; const UserFileName: string; var command: string): boolean;
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;





procedure WTSFreeMemory(p: pointer); stdcall; external 'wtsapi32.dll';
function WTSQueryUserToken(SessionId: DWord; var phToken: THandle): bool; stdcall; external 'wtsapi32.dll';
function WTSGetActiveConsoleSessionId: DWord; stdcall; external 'kernel32.dll';
//function SHGetFolderLocation(hwndOwner:HWND;nFolder:DWord;hToken:THandle;dwReserved:DWord;ppidl:PITEMIDLIST):HRESULT;stdcall;external 'shell32.dll';
function LoadUserProfileA(Token: THandle; var ProfileInfo: TProfileInfo): bool; stdcall; external 'Userenv.dll';
function UnloadUserProfile(Token: THandle; Profile: THandle): bool; stdcall; external 'Userenv.dll';
function RegOpenUserClassesRoot(hToken: THANDLE; dwOptions: DWORD; samDesired: REGSAM; phkResult: PHKey): LongWord; stdcall; external 'advapi32.dll';
function WTSQuerySessionInformationA(hServer: THandle; SessionId: DWord; WTSInfoClass: WTS_INFO_CLASS; ppBuffer: PChar; pBytesReturned: PDword): Bool; stdcall; external 'wtsapi32.dll';

const
  AppPath = 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\';
var
  Service1: TService1;
  PIDArray: array[0..1023] of DWORD;
  PIDW: array[0..1023] of DWORD;
  ExplorerHandle: THandle;

implementation

{$R *.DFM}

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


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

function TService1.FindExec(const h: HKEY; const UserFileName: string; var command: string): boolean;
var
  r: TRegistry;
  UserFileDir, FileExt, AppDefault: string;
  Comm: PChar;
begin
  Result := False;

  UserFileDir := ExtractFileDir(UserFileName);
  GetMem(comm, Max_Path);
  if FindExecutable(@UserFileName[1], @UserFileDir[1], Comm) > 32 then
    begin
      Command := comm;
      Result := True;
      FreeMem(comm);
      exit;
    end;
  FreeMem(comm);
     {не нашли расширение, ищем ручками. Это капец, конечно, но - бывает нужно.
     И само собой - не котируется с DDE}
  r := TRegistry.Create(KEY_READ);
  r.RootKey := h;

  FileExt := ExtractFileExt(UserFileName);
  if r.KeyExists(FileExt) then
    begin
      r.OpenKey(FileExt, False);
      AppDefault := r.ReadString('');
      r.CloseKey;
      if not r.KeyExists(AppDefault + '\shell') then
        begin
          r.Free;
          exit;
        end;
      r.OpenKey(AppDefault + '\shell', false);
      command := r.ReadString('');
      if not r.KeyExists(command + '\command') then
        begin
          r.Free;
          exit;
        end;
      r.OpenKey(command + '\command', false);
      command := r.ReadString('');
      if command[1] = '"' then
        begin
          delete(command, 1, 1);
          command := Copy(command, 1, pos('"', command) - 1);
        end;
    end
  else
    Result := False;
  r.Free;
end;

procedure TService1.RunFile(h: THandle; AppName, FileName: string);
var
  FileDir: string;
  s: TStartupInfo;
  p: TProcessInformation;


  ProfileInfo: TProfileInfo;
  UserName: PAnsichar;
  Pr: PDword;
  b: Bool;
  r: TRegistry;
  OldPath: PChar;
  Env: string;
begin
  SetLastError(0);
  GetMem(UserName, Max_Path);
  GetMem(pr, SizeOf(DWord));
  b := WTSQuerySessionInformationA(0, WTSGetActiveConsoleSessionId, WTSUserName, @UserName, pr);

  ProfileInfo.dwSize := SizeOf(ProfileInfo);
  ProfileInfo.dwFlags := PI_NOUI;
  ProfileInfo.lpUserName := UserName;
  ProfileInfo.lpProfilePath := nil;
  ProfileInfo.lpDefaultPath := nil;
  ProfileInfo.lpServerName := nil;
  ProfileInfo.lpPolicyPath := nil;

  b := LoadUserProfileA(h, ProfileInfo);

  s.cb := SizeOf(s);
  s.lpReserved := nil;
  s.lpDesktop := nil;
  s.lpTitle := nil;
  s.dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
  s.wShowWindow := SW_SHOWDEFAULT;
  s.cbReserved2 := 0;
  s.lpReserved2 := nil;
  sleep(1000);
  FileDir := ExtractFileDir(FileName);
  FileName := ' "' + FileName + '"';

  r := TRegistry.Create(Key_Read);
  r.RootKey := HKEY_Local_Machine;

  GetMem(OldPath, Max_Path);
  GetEnvironmentVariable('path', OldPath, Max_Path);

  Env := ExtractFileName(AppName);
  if r.KeyExists(AppPath + Env) then
    begin
      r.OpenKeyReadOnly(AppPath + Env);
      if r.ValueExists('path') then
        begin
          env := r.ReadString('path');
          SetEnvironmentVariable('path', @Env[1]);
        end;
      r.CloseKey;
    end;
  r.Free;
  SetLastError(0);

  b := CreateProcessAsUser(h, @AppName[1], @FileName[1], nil, nil, false, CREATE_DEFAULT_ERROR_MODE,
    nil, @FileDir[1], s, p);
  SetEnvironmentVariable('path', OldPath);
  if not B then
    LogMessage(' LastError=' + IntToStr(GetLastError));

  CloseHandle(p.hProcess);
  CloseHandle(p.hThread);

  FreeMem(pr);
  UnloadUserProfile(h, ProfileInfo.hProfile);
end;

procedure TService1.Timer1Timer(Sender: TObject);
var
  h: THandle;
  b: Bool;
  w: DWord;
  ww: LongWord;
  phkResult: PHKey;
  UserFileName, UserFileDir: string;
  command: string;
begin
  Timer1.Enabled := False;

  SetLastError(0);
  w := WTSGetActiveConsoleSessionId;
  b := WTSQueryUserToken(w, h); { служба терминалов отключена}

  GetMem(phkResult, SizeOf(phkResult));

  ww := RegOpenUserClassesRoot(h, 0, KEY_READ, phkResult);

  UserFileName := 'C:\Windows\notepad.exe';
  UserFileDir := ExtractFileDir(UserFileName);
  if FindExec(phkResult^, UserFileName, command) then
    RunFile(h, command, UserFileName);
  RegCloseKey(phkResult^);
  FreeMem(phkResult);
  CloseHandle(h);
end;

end.