software - delphi technologies

¿Cómo hago que la API de SetThreadDesktop funcione desde una aplicación de consola?

Question

Vi la pregunta de Stack Overflow ¿ Cómo cambiar un proceso entre el escritorio predeterminado y el escritorio de Winlogon? .

Y he producido un caso de prueba mínimo para crear una aplicación de proyecto de consola, pero SetThreadDesktop() no cambia mi programa al escritorio de destino.

¿Por qué pasó esto?

program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Winapi.Windows,
System.SysUtils,
Vcl.Graphics,
function RandomPassword(PLen: Integer): string;
var
str: string;
begin
Randomize;
str := ''abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'';
Result := '''';
repeat
Result := Result + str[Random(Length(str)) + 1];
until (Length(Result) = PLen)
end;
procedure Print;
var
DCDesk: HDC;
bmp: TBitmap;
hmod, hmod2 : HMODULE;
BitBltAPI: function(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): BOOL; stdcall;
GetWindowDCAPI: function(hWnd: HWND): HDC; stdcall;
begin
hmod := GetModuleHandle(''Gdi32.dll'');
hmod2:= GetModuleHandle(''User32.dll'');
if (hmod <> 0) and (hmod2 <> 0) then begin
bmp := TBitmap.Create;
bmp.Height := Screen.Height;
bmp.Width := Screen.Width;
GetWindowDCAPI := GetProcAddress(hmod2, ''GetWindowDC'');
if (@GetWindowDCAPI <> nil) then begin
DCDesk := GetWindowDCAPI(GetDesktopWindow);
end;
BitBltAPI := GetProcAddress(hmod, ''BitBlt'');
if (@BitBltAPI <> nil) then begin
BitBltAPI(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DCDesk, 0, 0, SRCCOPY);
bmp.SaveToFile(''ScreenShot_------_'' + RandomPassword(8) + ''.bmp'');
end;
ReleaseDC(GetDesktopWindow, DCDesk);
bmp.Free;
FreeLibrary(hmod);
FreeLibrary(hmod2);
end;
end;
//===============================================================================================================================
var
hWinsta, hdesktop:thandle;
begin
try
while True do
begin
hWinsta := OpenWindowStation(''WinSta0'', TRUE, GENERIC_ALL);
If hwinsta <> INVALID_HANDLE_VALUE then
begin
SetProcessWindowStation (hWinsta);
hdesktop := OpenDesktop (''default_set'', 0, TRUE, GENERIC_ALL);
if (hdesktop <> INVALID_HANDLE_VALUE) then
if SetThreadDesktop (hdesktop) then
begin
Print; // Captures screen of target desktop.
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;
end;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, '': '', E.Message);
end;
end.

Al verificar los errores, la llamada a SetThreadDesktop() falla con el código de error 170 ( ERROR_BUSY , el recurso solicitado está en uso ) cuando el escritorio de destino está abierto.

var
threahdesk: boolean;
...
threahdesk := SetThreadDesktop (hdesktop);
ShowMessage(IntToStr(GetLastError));
if threahdesk Then
begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;

Después de eso vi varias sugerencias en algunos foros, mi código real es el siguiente:

var
hWinsta, hdesktop:thandle;
threahdesk, setprocwst: Boolean;
////////////////////////////////////////////////////////////////////////////////
begin
try
while True do
begin
Application.Free;
hWinsta:= OpenWindowStation(''WinSta0'', TRUE, GENERIC_ALL);
If hwinsta <> 0 Then
Begin
setprocwst := SetProcessWindowStation(hWinsta);
if setprocwst then
hdesktop:= OpenDesktop(''default_set'', 0, TRUE, GENERIC_ALL);
If (hdesktop <> 0) Then
threahdesk := SetThreadDesktop(hdesktop);
Application := TApplication.Create(nil);
Application.Initialize;
Application.Run;
If threahdesk Then
Begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
End;
End;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, '': '', E.Message);
end;
end.

Answer 1

De la documentación de SetThreadDesktop() :

La función SetThreadDesktop fallará si el hilo de llamada tiene ventanas o ganchos en su escritorio actual (a menos que el parámetro hDesktop sea un identificador para el escritorio actual).

Answer 2

La respuesta de Dmitriy es precisa porque la función falla porque el hilo que llama tiene ventanas o ganchos, aunque no explica cómo.

La razón por la que SetThreadDesktop está fallando con ERROR_BUSY es que tiene "forms.pas" en su lista de usos. A pesar de que falta en el código que ha publicado (el punto y coma en la cláusula "uses" también falta la sugerencia de más unidades), el uso de la variable global Screen hace evidente que tiene "formas" en los usos. "Formularios" ingresa "controls.pas" que inicializa el objeto Application . En su constructor, la aplicación crea una ventana de utilidad para su PopupControlWnd . Puede haber otras ventanas creadas pero esta es razón suficiente para que la función falle.

Utiliza Screen para su ancho / alto. Sin usar "formularios", puede usar la API para recuperar esa información.

Existen otros problemas en el código, como la falta de verificación de error / errores que se mencionaron en los comentarios a la pregunta, pero no son relevantes para la falla de SetThreadDesktop .

El programa de ejemplo siguiente demuestra que no hay ningún problema para llamar a SetThreadDesktop en el hilo principal de una aplicación de consola, siempre que haya un escritorio con el nombre ''default_set'' en la estación de ventana en la que se ejecuta el programa y tiene derechos de acceso.

program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
// Vcl.Forms, // uncomment to get an ERROR_BUSY
Winapi.Windows;
var
hSaveDesktop, hDesktop: HDESK;
begin
hSaveDesktop := GetThreadDesktop(GetCurrentThreadId);
Win32Check(hSaveDesktop <> 0);
hDesktop := OpenDesktop(''default_set'', 0, True, GENERIC_ALL);
Win32Check(hDesktop <> 0);
try
Win32Check(SetThreadDesktop(hDesktop));
try
// --
finally
Win32Check(SetThreadDesktop(hSaveDesktop));
end;
finally
Win32Check(CloseDesktop(hDesktop));
end;
end.