delphi – 为什么截图不起作用(黑屏)？

服务是“允许服务与桌面交互”.

unit Unit1;

interface

uses
Windows,Messages,SysUtils,Classes,Graphics,Controls,SvcMgr,Dialogs;

type
  TcopyDesk = class(TService)
  procedure ServiceContinue(Sender: TService; var Continued: Boolean);
  procedure ServiceExecute(Sender: TService);
  procedure ServicePause(Sender: TService; var Paused: Boolean);
  procedure ServiceShutdown(Sender: TService);
  procedure ServiceStart(Sender: TService; var Started: Boolean);
  procedure ServiceStop(Sender: TService; var Stopped: Boolean);
  private
    procedure copyScreen(const Index: Integer);
  public
    function GetServiceController: TServiceController; override;
  end;

var
  copyDesk: TcopyDesk;

implementation

{$R *.DFM}

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

procedure TcopyDesk.copyScreen(const Index: Integer);
const
  DefaultwindowStation = 'WinSta0';
  DefaultDesktop = 'Default';
  CAPTUREBLT = $40000000;
  WINSTA_ALL_ACCESS = $0000037f;
var
  Bmp: TBitmap;
  hwinstaSave: HWINSTA;
  hdeskSave: HDESK;
  hwinstaUser: HWINSTA;
  hdeskUser: HDESK;
  dwThreadId: DWORD;
  hdcScreen : HDC;
  hdcCompatible : HDC;
  hbmScreen : HBITMAP;
begin
  hwinstaUser:= OpenWindowStation(DefaultwindowStation,FALSE,WINSTA_ALL_ACCESS);

  hwinstaSave:= GetProcessWindowStation;
  if hwinstaUser = 0 then
  begin
    OutputDebugString(PChar('OpenWindowStation Failed' + SysErrorMessage       (GetLastError)));
    exit;
  end;

  if not SetProcessWindowStation(hwinstaUser) then
  begin
    OutputDebugString('SetProcessWindowStation Failed');
    exit;
  end;

//  hdeskUser:= OpenDesktop(DefaultDesktop,MAXIMUM_ALLOWED);
  hdeskUser:= OpenInputDesktop(0,False,MAXIMUM_ALLOWED);
  if hdeskUser = 0 then
  begin
    OutputDebugString('OpenDesktop Failed');
    SetProcessWindowStation (hwinstaSave);
    CloseWindowStation (hwinstaUser);
    exit;
  end;
  dwThreadId:= GetCurrentThreadID;

  hdeskSave:= GetThreadDesktop(dwThreadId);

  if not SetThreadDesktop(hdeskUser) then
  begin
    OutputDebugString(PChar('SetThreadDesktop' + SysErrorMessage(GetLastError)));
    Exit;
  end;

  try
    hdcScreen := GetDC(0);//GetDC(GetDesktopWindow);//CreateDC('disPLAY',nil,nil);
    hdcCompatible := CreateCompatibleDC(hdcScreen);
    hbmScreen := CreateCompatibleBitmap(hdcScreen,GetDeviceCaps(hdcScreen,HORZRES),VERTRES));
    SelectObject(hdcCompatible,hbmScreen);
    bmp:= TBitmap.Create;
    bmp.Handle:= hbmScreen;
    BitBlt(hdcCompatible,bmp.Width,bmp.Height,hdcScreen,SRCcopY OR CAPTUREBLT);
    Bmp.SavetoFile('C:\Users\Public\ScreenShot\' + IntToStr(Index) + '.bmp');
  finally
    DeleteDC(hdcScreen);
    DeleteDC(hdcCompatible);
    Bmp.Free;
    Bmp:= nil;
  end;
  SetThreadDesktop(hdeskSave);
  SetProcessWindowStation(hwinstaSave);
  if hwinstaUser <> 0 then
    CloseWindowStation(hwinstaUser);
  if hdeskUser <> 0 then
    CloseDesktop(hdeskUser);
end;

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

procedure TcopyDesk.ServiceContinue(Sender: TService;
  var Continued: Boolean);
begin
  while not Terminated do
  begin
    Sleep(10);
    ServiceThread.ProcessRequests(False);
  end;
end;

procedure TcopyDesk.ServiceExecute(Sender: TService);
var
  Index: Integer;
begin
  Index:= 0;
  while not Terminated do
  begin
    copyScreen(Index);
    Inc(Index);
    ServiceThread.ProcessRequests(False);
//    Sleep(1000);
//    if Index = 4 then
      DoStop;
  end;
end;

procedure TcopyDesk.ServicePause(Sender: TService; var Paused: Boolean);
begin
  Paused:= True;
end;

procedure TcopyDesk.ServiceShutdown(Sender: TService);
begin
  Status:= csstopped;
  ReportStatus();
end;

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

procedure TcopyDesk.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  Stopped:= True;
end;
end.

解决方法

在Vista及更高版本中,服务将无法截取屏幕截图,或以其他方式与桌面交互 – 不再支持“允许服务与桌面交互”.服务在无法与桌面交互的隔离会话中运行.有关详细信息,请阅读“ session 0 isolation”.

有关原因的更多背景,this thread explains：

As multiples sessions are running because of terminal services or remote desktop connections there is no one to one relationship between a service and an interactive window station with one desktop. You can have one per interactive session. Which one should the service talk to? What if nobody looks at any desktop of the machine your service runs on – nobody notices that messageBox or whatever UI stuff.

Relying on that “feature” is just not adequate anymore. Get rid of it,there will be no alternative.