主要用来做远程桌面使用,可切换工作桌面来捕捉屏幕.

dfm窗体文件:

object CopyDeskService: TCopyDeskService
OldCreateOrder = False
OnCreate = ServiceCreate
OnDestroy = ServiceDestroy
AllowPause = False
DisplayName = 'Copy Desk Service'
Interactive = True
Left = 192
Top = 107
Height = 150
Width = 215
end

Pas文件:

unit Main;

interface

uses
Windows, SysUtils, Classes, Graphics, SvcMgr;

type
TCopyThread = class(TThread)
private
FIndex: DWORD;
FScrBmp: TBitmap;
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;

TCopyDeskService = class(TService)
procedure ServiceCreate(Sender: TObject);
procedure ServiceDestroy(Sender: TObject);
private
FCopyThread: TCopyThread;
public
function GetServiceController: TServiceController; override;
end;

var
CopyDeskService: TCopyDeskService;

implementation

{$R *.DFM}

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

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

procedure TCopyDeskService.ServiceCreate(Sender: TObject);
begin
FCopyThread := TCopyThread.Create;
end;

procedure TCopyDeskService.ServiceDestroy(Sender: TObject);
begin
FCopyThread.Terminate;
end;

function SelectHDESK(HNewDesk: HDESK): Boolean; stdcall;
var
HOldDesk: HDESK;
dwDummy: DWORD;
sName: array[0..255] of Char;
begin
Result := False;
HOldDesk := GetThreadDesktop(GetCurrentThreadId);
if (not GetUserObjectInformation(HNewDesk, UOI_NAME, @sName[0], 256, dwDummy)) then
begin
OutputDebugString('GetUserObjectInformation Failed.');
Exit;
end;
if (not SetThreadDesktop(HNewDesk)) then
begin
OutputDebugString('SetThreadDesktop Failed.');
Exit;
end;
if (not CloseDesktop(HOldDesk)) then
begin
OutputDebugString('CloseDesktop Failed.');
Exit;
end;
Result := True;
end;

function SelectDesktop(pName: PChar): Boolean; stdcall;
var
HDesktop: HDESK;
begin
Result := False;
if Assigned(pName) then
HDesktop := OpenDesktop(pName, 0, False,
DESKTOP_CreateMENU or DESKTOP_CreateWINDOW or
DESKTOP_ENUMERATE or DESKTOP_HOOKCONTROL or
DESKTOP_WRITEOBJECTS or DESKTOP_READOBJECTS or
DESKTOP_SWITCHDESKTOP or GENERIC_WRITE)
else
HDesktop := OpenInputDesktop(0, False,
DESKTOP_CreateMENU or DESKTOP_CreateWINDOW or
DESKTOP_ENUMERATE or DESKTOP_HOOKCONTROL or
DESKTOP_WRITEOBJECTS or DESKTOP_READOBJECTS or
DESKTOP_SWITCHDESKTOP or GENERIC_WRITE);
if (HDesktop = 0) then
begin
OutputDebugString(PChar('Get Desktop Failed: ' + IntToStr(GetLastError)));
Exit;
end;
Result := SelectHDESK(HDesktop);
end;

function InputDesktopSelected: Boolean; stdcall;
var
HThdDesk: HDESK;
HInpDesk: HDESK;
dwError: DWORD;
dwDummy: DWORD;
sThdName: array[0..255] of Char;
sInpName: array[0..255] of Char;
begin
Result := False;
HThdDesk := GetThreadDesktop(GetCurrentThreadId);
HInpDesk := OpenInputDesktop(0, False,
DESKTOP_CreateMENU or DESKTOP_CreateWINDOW or
DESKTOP_ENUMERATE or DESKTOP_HOOKCONTROL or
DESKTOP_WRITEOBJECTS or DESKTOP_READOBJECTS or
DESKTOP_SWITCHDESKTOP);
if (HInpDesk = 0) then
begin
OutputDebugString('OpenInputDesktop Failed.');
dwError := GetLastError;
Result := (dwError = 170);
Exit;
end;
if (not GetUserObjectInformation(HThdDesk, UOI_NAME, @sThdName[0], 256, dwDummy)) then
begin
OutputDebugString('GetUserObjectInformation HThdDesk Failed.');
CloseDesktop(HInpDesk);
Exit;
end;
if (not GetUserObjectInformation(HInpDesk, UOI_NAME, @sInpName[0], 256, dwDummy)) then
begin
OutputDebugString('GetUserObjectInformation HInpDesk Failed.');
CloseDesktop(HInpDesk);
Exit;
end;
CloseDesktop(HInpDesk);
Result := (lstrcmp(sThdName, sInpName) = 0);
end;

procedure CopyScreen(Bmp: TBitmap; out Index: DWORD);
var
DC: HDC;
begin
DC := GetDC(0);
Bmp.Width := GetSystemMetrics(SM_CXSCREEN);
Bmp.Height := GetSystemMetrics(SM_CYSCREEN);
Bmp.Canvas.Lock;
try
BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, DC, 0, 0, SRCCOPY);
Bmp.SaveToFile('j:\p' + IntToStr(Index) + '.bmp');
Inc(Index);
finally
Bmp.Canvas.Unlock;
ReleaseDC(0, DC);
end;
end;

constructor TCopyThread.Create;
begin
FreeOnTerminate := True;
FScrBmp := TBitmap.Create;
FScrBmp.PixelFormat := pf8bit;
FIndex := 0;
inherited Create(False);
end;

destructor TCopyThread.Destroy;
begin
FScrBmp.Free;
FScrBmp := nil;
inherited;
end;

procedure TCopyThread.Execute;
begin
while (not Terminated) do
begin
if InputDesktopSelected then CopyScreen(FScrBmp, FIndex)
else if SelectDesktop(nil) then CopyScreen(FScrBmp, FIndex);
Sleep(3000);
end;
end;

end.