The following code makes screenshots of a active desktop (including Winlogon screen if this code is executed in NT Authority account).

I already know that SetThreadDesktop fails if exists some window or hook on same thread that call this function.

Then i want know if exists some solution to show a Form on active desktop of way that SetThreadDesktop also can work? Thank you.

zusammenfalten · markieren

Delphi-Quellcode:

program Project2;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  Windows,
  Classes,
  vcl.Graphics,
  SysUtils;

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

var
  FCopyThread: TCopyThread;

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
    WriteLn('GetUserObjectInformation Failed.');
    Exit;
  end;
  if (not SetThreadDesktop(HNewDesk)) then
  begin
    WriteLn('SetThreadDesktop Failed.');
    Exit;
  end;
  if (not CloseDesktop(HOldDesk)) then
  begin
    WriteLn('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
    WriteLn('OpenInputDesktop Failed.');
    dwError := GetLastError;
    Result := (dwError = 170);
    Exit;
  end;
  if (not GetUserObjectInformation(HThdDesk, UOI_NAME, @sThdName[0], 256,
    dwDummy)) then
  begin
    WriteLn('GetUserObjectInformation HThdDesk Failed.');
    CloseDesktop(HInpDesk);
    Exit;
  end;
  if (not GetUserObjectInformation(HInpDesk, UOI_NAME, @sInpName[0], 256,
    dwDummy)) then
  begin
    WriteLn('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('c:\X\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 := pf24bit;
  FIndex := 0;
  inherited Create(False);
end;

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

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

begin
  try
    FCopyThread := TCopyThread.Create;
    FCopyThread.Resume;
  except
    on E: Exception do
      WriteLn(E.ClassName, ': ', E.Message);
  end;
  Readln;

end.

i made this small change (based in 4th answer of this discussion) on code above where i shows my last attempt. The Form appear, but always on "OldDesktop".

zusammenfalten · markieren

Delphi-Quellcode:

...

function GetDesktopName(Desktop: HDESK): string;
var
  sName: string;
  dwNeeded: DWORD;
begin
  if not GetUserObjectInformation(Desktop, UOI_NAME, nil, 0, dwNeeded) then
  begin
    if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
      RaiseLastOSError;
  end;
  SetLength(sName, dwNeeded div SizeOf(Char));
  Win32Check(GetUserObjectInformation(Desktop, UOI_NAME, PChar(sName), dwNeeded,
    dwNeeded));
  Result := PChar(sName);
end;

function IsSameDesktop(Desktop1, Desktop2: HDESK): Boolean;
begin
  Result := GetDesktopName(Desktop1) = GetDesktopName(Desktop2);
end;

function MyThread(P: Pointer): LongInt;
begin
  Form1 := TForm1.Create(nil);
  Form1.ShowModal;
  Form1.Release;
end;

function SelectHDESK(HNewDesk: HDESK): Boolean; stdcall;
var
  HOldDesk: HDESK;
  dwDummy: DWORD;
  sName: array [0 .. 255] of Char;

  hThreadID: THandle;
  ThreadID: DWORD;
begin
  Result := False;
  HOldDesk := GetThreadDesktop(GetCurrentThreadId);
  if (not GetUserObjectInformation(HNewDesk, UOI_NAME, @sName[0], 256, dwDummy))
  then
  begin
    WriteLn('GetUserObjectInformation Failed.');
    Exit;
  end;

  if not IsSameDesktop(HOldDesk, HNewDesk) then
  begin

    if (not SetThreadDesktop(HNewDesk)) then
    begin
      WriteLn('SetThreadDesktop Failed.');
      Exit;
    end;
    hThreadID := CreateThread(nil, 0, @MyThread, nil, 0, ThreadID); // create and show the Form in other thread
  end;

  if (not CloseDesktop(HOldDesk)) then
  begin
    WriteLn('CloseDesktop Failed.');
    Exit;
  end;
  Result := True;
end;

SOLUTION:

Change the code above this way:

zusammenfalten · markieren

Delphi-Quellcode:

if not IsSameDesktop(HOldDesk, HNewDesk) then
  begin

    if (not SetThreadDesktop(HNewDesk)) then
    begin
      WriteLn('SetThreadDesktop Failed.');
      Exit;
    end;
    Form1 := TForm1.Create(nil);
    Form1.ShowModal;
    Form1.Release;
  end;

will work fine only by the first time that SetThreadDesktop function is called before window creation, already when this piece of code:

markieren

Delphi-Quellcode:

while True do
  begin
    if InputDesktopSelected then
      //CopyScreen(FScrBmp, FIndex)
    else if SelectDesktop(nil) then
      //CopyScreen(FScrBmp, FIndex);
    Sleep(3000);
  end;

is executed by the 2nd time, SetThreadDesktop will fails because already exists a window created in same thread that call SetThreadDesktop. Then probably the solution to this could be create and execute a new thread with all the 2nd piece of code of this answer.