虚拟桌面服务程序
program Desktop;

uses
SvcMgr,
Unit_Main in 'Unit_Main.pas' {Service_Desktop: TService},
Unit_Thread in 'Unit_Thread.pas';

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TService_Desktop, Service_Desktop);
Application.Run;
end.

////////////////////////////////////

unit Unit_Main;

interface

uses
Windows,Classes,SvcMgr,activex, ExtCtrls;

type
TService_Desktop = class(TService)
Timer_Check: TTimer;
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure Timer_CheckTimer(Sender: TObject);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
private
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;

var
Service_Desktop: TService_Desktop;

implementation

uses Unit_Thread,ShellApi;

{$R *.DFM}

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

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

procedure TService_Desktop.ServiceStart(Sender: TService;
var Started: Boolean);
begin
Timer_Check.Enabled:=True;
end;

procedure TService_Desktop.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Timer_Check.Enabled:=False;
end;

procedure TService_Desktop.Timer_CheckTimer(Sender: TObject);
begin
Timer_Check.Enabled:=False;
with TThreadDesktop.Create do
try
FreeOnTerminate:=True;
WaitFor;
except end;
Timer_Check.Enabled:=True;
end;

end.
//////////////////////////////////

//Windows desktop application
//Made by Daniel Vladutu
// www.free-soft.ro
unit Unit_Thread;

interface

uses Classes,Windows,SysUtils;

type
TThreadDesktop = class(TThread)
private
procedure SwitchToDesktop(DesktopName: String);
function CreateDesktop(DesktopName: String): HDESK;
procedure EnumerateDesktops;
protected
procedure Execute; override;
published
constructor Create;
property ReturnValue;

end;

implementation

uses Unit_Main;
var List_Desktops:TStringList;

function EnumDesktopProc(Desktop: LPTSTR; Param: LParam): Boolean; stdcall;
begin
if (Desktop<>'Winlogon') and (Desktop<>'Disconnect') then List_Desktops.Insert(0,Desktop);
result := True;
end;

constructor TThreadDesktop.Create;
begin
List_Desktops:=TStringList.Create;
inherited Create(false);
end;

procedure TThreadDesktop.Execute;
var Desk: HDESK;
hDesk:THandle;
i:Integer;
begin
ReturnValue:=0;
Desk := OpenDesktop('Default', 0, False, MAXIMUM_ALLOWED);
if Desk<>0 then
begin
if GetKeyState(VK_LMENU) < 0 then //We press on LeftAlt button
begin
EnumerateDesktops;
for i:=$31 to $39 do
if (GetKeyState(i)<0) and (List_Desktops.Count>i-$31) then
begin
SwitchToDesktop(List_Desktops[i-$31]);
Break;
end;
end;
end;
CloseDesktop(Desk);
FreeAndNil(List_Desktops);
end;

function TThreadDesktop.CreateDesktop(DesktopName: String): HDESK;
var Desk: HDESK;
begin
Desk := Windows.CreateDesktop(PChar(DesktopName), nil, nil, 0, MAXIMUM_ALLOWED, nil);
List_Desktops.Insert(0, DesktopName);
result := Desk;
end;

procedure TThreadDesktop.EnumerateDesktops;
begin
List_Desktops.Clear;
EnumDesktops(GetProcessWindowStation, @EnumDesktopProc, Integer(Self));
end;

procedure TThreadDesktop.SwitchToDesktop(DesktopName: String);
var Desk: HDESK;
begin
Desk:=OpenDesktop(PChar(DesktopName), DF_ALLOWOTHERACCOUNTHOOK, False, MAXIMUM_ALLOWED);
Sleep(100);
SwitchDesktop(Desk);
CloseDesktop(Desk);
end;

end.

////////////////////////////////////

加载服务程序源代码

program DesktopLoader;
//{$APPTYPE CONSOLE}
uses Windows,WinSvc,ShellApi;
var s:String;
iDesktops,jDesktops:Integer;
ServiceName:String='Service_Desktop';

procedure RunProgram(CmdLine:String);
var StartupInfo:TStartUpInfo;
ProcessInformation:TProcessInformation;
Handle:THandle;
d:DWord;
begin
FillChar(StartUpInfo,SizeOf(StartUpInfo),0);
StartUpInfo.cb:=SizeOf(TStartUpInfo);
if CreateProcess(nil,PChar(CmdLine),nil,nil,False, Create_Separate_WOW_VDM,nil,nil, StartUpInfo,ProcessInformation) then
begin
Handle:=OpenProcess(Synchronize or Standard_Rights_Required or $FFF, True, ProcessInformation.dwProcessID);
while GetExitCodeProcess(Handle,d) and (d=Still_Active) do sleep(10);
end;
end;

function RegistryWriteStartup:boolean;
var Key:HKEY;
begin
result := false;
if cardinal(RegCreateKey(HKEY_LOCAL_MACHINE, PChar('SOFTWARE\Microsoft\Windows\CurrentVersion\Run'),Key))=0 then
try result := RegSetValueEx(Key, PChar('Desktop Service'), 0, REG_SZ, PChar(ParamStr(0)), Length(ParamStr(0)) + 1) = 0;
finally RegCloseKey(Key)end;
end;

function IntToStr(Number:Cardinal):String;
begin
Result:='';
if Number=0 then Result:='0';
while Number>0 do
begin
Result:=Char((Number mod 10)+Integer('0'))+Result;
Number:=Number div 10;
end;
end;

function FileExists(FileName:String):boolean;
var FindData: TWin32FindData;
begin
result:=FindFirstFile(PChar(FileName), FindData)<> INVALID_HANDLE_VALUE;
end;

function WindowDirectory:String ;
var Buffer:PChar ;
Begin
result:='';buffer:=nil;
try
getmem(buffer,255) ;
GetWindowsDirectory(Buffer,255);
Result:=Buffer;
finally
FreeMem(buffer);
end;
if Result[Length(Result)]<>'\' then Result:=Result+'\';
end;

function ServiceIsInstalled(Machine:string;ServiceType,ServiceState:DWord):boolean;
type TSvc=array[0..4096] of TEnumServiceStatus;
PSvc=^TSvc;
var j:integer;
SC:SC_Handle;
nBytesNeeded,nServices,nResumeHandle : DWord;
Svc:PSvc;
begin
Result := false;
SC := OpenSCManager(PChar(Machine),Nil,SC_MANAGER_ALL_ACCESS);
if SC>0 then
begin
nResumeHandle := 0;
New(Svc);
EnumServicesStatus(SC,ServiceType,ServiceState,Svc^[0],SizeOf(Svc^),nBytesNeeded,nServices,nResumeHandle);
// for j := 0 to nServices-1 do MessageBox(0,Pchar(Svc^[j].lpServiceName),'',0);
for j := 0 to nServices-1 do if Svc^[j].lpServiceName=ServiceName then result:=true;
Dispose(Svc);
CloseServiceHandle(SC);
end;
end;

function ServiceStart(Machine,Service:string):boolean;
var SC1,SC2:SC_Handle;
Status:TServiceStatus;
c:PChar;
d:DWord;
begin
Status.dwCurrentState := 0;
SC1 := OpenSCManager(PChar(Machine),Nil,SC_MANAGER_CONNECT);
if SC1>0 then
begin
SC2 := OpenService(SC1,PChar(Service),SERVICE_START or SERVICE_QUERY_STATUS);
if SC2>0 then
begin
c:=Nil;
if StartService(SC2,0,c) and QueryServiceStatus(SC2,Status)then
while SERVICE_RUNNING<>Status.dwCurrentState do
begin
d := Status.dwCheckPoint;
Sleep(Status.dwWaitHint);
if not QueryServiceStatus(SC2,Status) then break;
if Status.dwCheckPointend;
CloseServiceHandle(SC2);
end;
CloseServiceHandle(SC1);
end;
Result:=SERVICE_RUNNING=Status.dwCurrentState;
end;

function ServiceStop(Machine,Service:string):boolean;
var SC1,SC2:SC_Handle;
Status:TServiceStatus;
d:DWord;
begin
SC1:=OpenSCManager(PChar(Machine),Nil,SC_MANAGER_CONNECT);
if SC1>0 then
begin
SC2 := OpenService(SC1,PChar(Service),SERVICE_STOP or SERVICE_QUERY_STATUS);
if SC2>0 then
begin
if ControlService(SC2,SERVICE_CONTROL_STOP,Status) and QueryServiceStatus(SC2,Status) then
while SERVICE_STOPPED<>Status.dwCurrentState do
begin
d:=Status.dwCheckPoint;
Sleep(Status.dwWaitHint);
if not QueryServiceStatus(SC2,Status) then break;
if Status.dwCheckPointend;
CloseServiceHandle(SC2);
end;
CloseServiceHandle(SC1);
end;
Result:=SERVICE_STOPPED=Status.dwCurrentState;
end;

function ServiceCreate(Machine,Service,FileName:String ) : Boolean;
var SC1,SC2:SC_Handle;
begin
MessageBox(0,PChar(Service),'service',0);
Result:=False;
SC1:=OpenSCManager(PChar(Machine),Nil,SC_MANAGER_Create_SERVICE);
if SC1>0 then
begin
SC2:=CreateService(SC1,PChar(Service),PChar(Service),SERVICE_ALL_ACCESS,SERVICE_WIN32_OWN_PROCESS,
SERVICE_AUTO_START,SERVICE_ERROR_NORMAL,PChar(FileName),nil,nil,nil,nil,nil);
Result:=SC2<>0;
If Result Then CloseServiceHandle(SC2);
CloseServiceHandle(SC1);
end;
end;

function ServiceGetStatus(Machine,Service:string):DWord;
var SC1,SC2:SC_Handle;
Status:TServiceStatus;
d:DWord;
begin
SC1:=OpenSCManager(PChar(Machine),Nil,SC_MANAGER_CONNECT);
if SC1>0 then
begin
SC2:=OpenService(SC1,PChar(Service),SERVICE_QUERY_STATUS);
if SC2>0 then
begin
if QueryServiceStatus(SC2,Status) then d:=Status.dwCurrentState;
CloseServiceHandle(SC2);
end;
CloseServiceHandle(SC1);
end;
Result:=d;
end;

function EnumDesktopProc(Desktop: LPTSTR; Param: LParam): Boolean; stdcall;
begin
if (Desktop<>'Winlogon') and (Desktop<>'Disconnect') then inc(iDesktops);
result := True;
end;

function NewDesktop:Boolean;
var sDesktop:string;
sinfo:TStartupInfo;
pinfo:TProcessInformation;
Desk:HDESK;
begin
result:=false;
sDesktop:='Desktop '+IntToStr(iDesktops);
Desk:=CreateDesktop(PChar(sDesktop), nil, nil, 0, MAXIMUM_ALLOWED, nil);
try
FillChar(sinfo, SizeOf(sinfo), 0);
sinfo.cb := SizeOf(sinfo);
sinfo.lpDesktop := PChar(sDesktop);
Sleep(500);
CreateProcess(PChar(WindowDirectory+'explorer.exe'), nil, nil, nil, False, 0, nil, nil, sinfo, pinfo);
Sleep(2000);
result:=true;
CloseDesktop(Desk);
except
CloseDesktop(Desk);
end;
end;

begin
RegistryWriteStartup;
if not ServiceIsInstalled('',SERVICE_WIN32,SERVICE_STATE_ALL) then
begin
s:=ParamStr(0);
while (s<>'') and (s[Length(s)]<>'\') do Delete(s,Length(s),1);
s:=s+'Desktop.exe';
if not FileExists(s) then
begin
MessageBox(0,PChar('Desktop service "'+s+'" does not exits!'),PChar('Error'),0);
exit;
end;
RunProgram(s+' -install');
// if not ServiceCreate('',ServiceName,s) then MessageBox(0,'Could not install the service','Error',0);
// if not ServiceIsInstalled('',SERVICE_WIN32,SERVICE_STATE_ALL) then
// begin
// MessageBox(0,'Could not install the Desktop service.','Error',0);
// exit;
// end;
end;
case ServiceGetStatus('',ServiceName) of
SERVICE_RUNNING:;
SERVICE_STOPPED: ServiceStart('',ServiceName);
SERVICE_PAUSED: ;
end;
if ServiceGetStatus('','Service_Desktop')<>SERVICE_RUNNING then
begin
MessageBox(0,PChar('Could not start the Desktop service'),'Error',0);
exit;
end;
iDesktops:=0;
EnumDesktops(GetProcessWindowStation, @EnumDesktopProc,0);
if iDesktops>3 then exit;
NewDesktop;
jDesktops:=iDesktops;iDesktops:=0;
EnumDesktops(GetProcessWindowStation, @EnumDesktopProc,0);
if (iDesktops=jDesktops+1) then
ShellExecute(0,nil,PChar(ParamStr(0)),nil,nil,SW_SHOWNORMAL);
end.

///////////////////////

使用方法

ALT+1,ALT+2,ALT+3切换3个桌面