Функция SetThreadDesktop: Как показать форму на любом активном рабочем столе? - PullRequest
Новая
       13

Функция SetThreadDesktop: Как показать форму на любом активном рабочем столе?

0 голосов
/ 06 декабря 2018

Следующий код делает снимки экрана активного рабочего стола (включая экран Winlogon, если этот код выполняется в учетной записи NT Authority ).Я уже знаю, что SetThreadDesktop терпит неудачу, если существует какое-то окно или зацепка в том же потоке, который вызывает эту функцию.Тогда я хочу знать, существует ли какое-либо решение для отображения формы на активном рабочем столе, способ, которым SetThreadDesktop также может работать?Спасибо .. 

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.

РЕДАКТИРОВАТЬ:

Я только хочу решение для вызова формы после этой строки: CopyScreen(FScrBmp, FIndex) в TCopyThread.Execute;(Я пытался Form1 := TForm1.Create(Form1);Form1.Show, но SetThreadDesktop не удается).Или какой-то другой вариант, который мог бы работать.

EDIT2:

Я внес небольшое изменение в код выше, где я показываю свою последнюю попытку.Форма появляется, но всегда на «OldDesktop». 

...

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;

1 Ответ

0 голосов
/ 08 декабря 2018

РЕШЕНИЕ:

Измените код выше таким образом: 

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;

будет работать нормально только в первый раз, когда SetThreadDesktop функция вызывается перед созданием окна ( + 1 за 1-й комментарий @Remy Lebeau, большое спасибо!), Уже когда этот кусок кода: 

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

выполняется во второй раз, SetThreadDesktop завершится неудачно, поскольку уже существует окно, созданное в том же потоке, которое вызывает SetThreadDesktop.Тогда решение этой проблемы - создать и выполнить новый поток со всем вторым фрагментом кода этого ответа.

...