Screen Shot рабочего стола из не основного потока

[Dimitr69]

Здравствуйте, граждане программеры.
Вопрос: как получить СкринШот из вторичного потока?

Получение скринов в основной программе задача простая. Одна из функций

function GetWinImage(HWin: HWND; bm: Vcl.Graphics.TBitMap;
  var err: string): boolean;
var
  // Left, Top, Width, Height: Word;
  R: tRect;
  dc: HDC;
  lpPal: PLOGPALETTE;
begin
  result := false;
  if not IsWindow(HWin) then
  begin
    err := 'Error! It is not Window!';
    exit; // переданный дескриптор не окно
  end;

  GetWindowRect(HWin, R);
  bm.Width := R.Width;
  bm.Height := R.Height;

  { get the screen dc }
  dc := GetDC(HWin);
  if (dc = 0) then
  begin
    err := 'Can not get context!';
    exit; // не получили контекст устройства
  end;
  
   // без кода что пониже и так все прекрасно работает
  // поэтому закомментировал, но Вы можете раскомментить ...
  try
    { do we have a palette device? }
    // if (GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE) then
    // begin
    // { allocate memory for a logical palette }
    // GetMem(lpPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    // { zero it out to be neat }
    // FillChar(lpPal^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)), #0);
    // { fill in the palette version }
    // lpPal^.palVersion := $300;
    // { grab the system palette entries }
    // lpPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256,
    // lpPal^.palPalEntry);
    // if (lpPal^.palNumEntries <> 0) then
    // begin
    // { create the palette }
    // bm.Palette := CreatePalette(lpPal^);
    // end;
    // FreeMem(lpPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    // end;
    { copy from the screen to the bitmap }
    try
      BitBlt(bm.Canvas.Handle, 0, 0, R.Width, R.Height, dc, R.Left,
        R.Top, SRCCopy);
      result := true;
    except
      err := 'Execute BitBlt Error!';
    end;

    { release the screen dc }
  finally
    ReleaseDc(HWin, dc);
  end;
end;

Вызов данной функции , след (и все это работает из основного потока без вопросов):

var
   bm:VCL.Graphics.TBitMap;
...

   bm := VCL.Graphics.TBitMap.Create;
  // получим экран
   GetWinImage(GetDeskTopWindow,bm);

  // загрузим картину в имидж на форме приложения
  Image1.Picture.BitMap.Assign(bm);

  bm.Free;

Однако....
получение скриншотов из вторичного потока, не кАтит. Получаю белый или черный квадрат (проверял на разных осях Serv2003, XP, W7)
Т.е., имея след поток

  TScreenShotThread = class(TThread)
    private
      fDestToph : tHandle;
    protected
      Procedure Execute; override;
    public
    BM:TbitMap;
    Constructor Create(); 
    Destructor Destroy; override;
    end;

...
   Constructor Create(); 
    begin
     Inherited Create(true);// поток будет приостановлен, в приложении надо будет стартовать
    BM := TbitMap.Create;
    fDestToph:=GetDeskTopWindow();
    end; 

  Destructor Destroy;
  begin
    BM.Free;
    Inherited;
  end;

  procedure TScreenShotThread.Execute;
  var
     I:Integer;  
  begin
     inherited;
     While Not Terminated do
     begin
       GetWinImage(fDestToph,self.BM);
       SaveBMToFile(self.BM, tmpFileName);// приблизит функция ...
       sleep(3000); 
     end;

  end;

Основной вопрос след:
Как получить стабильный скриншот экрана из вторичного потока?
Все методы функций скриншотов из DRKB3_Full.chm мною перепробованы и работают гарантированно из основного потока!

[Stilet]

Хм... BitBlt() это функция WinAPI и ее не через Try нужно проверять а через If.
проверь что она возвращает:

if not BitBlt(...) выводим код, который вернет GetLastError()

[min@y™]

Вот кусок кода из Delphi Works:

function dwMakeMonitorShapshot(const Index: Byte; Bitmap: Graphics.TBitmap): Boolean;
var
  	Desktop: HDC;
  	Left, Top, Height, Width: Integer;
  	rcMonitor: TRect;
begin
   rcMonitor:= dwGetMonitorRect(Index);
   Left:= rcMonitor.Left;
   Top:= rcMonitor.Top;
   Height:= rcMonitor.Bottom - rcMonitor.Top;
   Width:= rcMonitor.Right - rcMonitor.Left;
  	Bitmap.Height := Height;
  	Bitmap.Width := Width;
  	Desktop := CreateDC('', PChar(dwScreenDeviceName(Index)), NIL, NIL);
  	BitBlt(Bitmap.Canvas.Handle, 0, 0, Width, Height, Desktop, 0, 0, SRCCOPY);
  	DeleteDC(Desktop);
end;

Эта функция делает скрин экрана указанного монитора.
Попробуй вызвать её из потока.

[Dimitr69]

Спасибо добрым людям, что отозвались. Однако...
Код, что подсказали выше, я переделал, без использования громоздкого пакет библиотек DelphiWorks, получалось это:

function MakeMonitorShapshot(Bitmap: Vcl.Graphics.TBitMap;
  var err: string): boolean;
var
  Desktop: HDC;
  Left, Top, Height, Width: Integer;
  rcMonitor: tRect;
begin
  result := false;
  // rcMonitor:= dwGetMonitorRect(Index);
  GetWindowRect(getdeskTopWindow, rcMonitor); // размеры экрана

  Left := rcMonitor.Left;
  Top := rcMonitor.Top;
  Height := rcMonitor.Bottom - rcMonitor.Top;
  Width := rcMonitor.Right - rcMonitor.Left;
  Bitmap.Height := Height;
  Bitmap.Width := Width;

  Desktop := CreateDC('DISPLAY', '', 0, 0); // контекст экрана
  // фиксируем ошибку создания контекста дисплея
  if Desktop = 0 then
  begin
    err := 'CreateDC proc Error! GetLastError = ' + IntTostr(GetLastError());
    exit;
  end;

  try
    // фиксируем ошибку  BitBlt, если она есть
    result := BitBlt(Bitmap.Canvas.Handle, 0, 0, Width, Height, Desktop, 0,
      0, SRCCopy);

    if Not result then
      err := 'BitBlt proc Error! GetLastError = ' + IntTostr(GetLastError());

  finally
    DeleteDC(Desktop);
  end;
end;

Он также успешно возвращает скрин экрана, и работает в отдельном потоке, но на данной машине. И даже не нек удаленных машинах... Но не на всех, (на ПК c ОС Win2003, не работает)

Концепция создаваемого приложение - использование DataSnap технологии (Delphi XE2) Создается клиент-серверное приложение. Одной из функций приложения - получение удаленных Скрин Шотов.

в модуле серверных методов, объявлен метод GetStream, который возвращает поток (это может быть скриншот (битмап записанный в МемСтрим), это может быть ClientDataSet (предварит созданный и записанный в мем стрим), это может быть наконец просто файл, открытый с флагом fmShareDenyNone)

type
  TServerMethods1 = class(TDSServerModule)
...
public
       function GetStream(const rmt_hosts: string; prm1: integer;
      const prm2: string; var rez: string): tStream; // tested!

так вот... серверные методы выполняются в отдельном потоке. И когда
он , по запросу клиента, должен возвратить скрин экрана, процедура
скринШота не всегда срабатывает и возвращает скриновый поток.

Наблюдается ошибка при выполнении функции BitBlt.
Так для функции function MakeMonitorShapshot(Bitmap: cl.Graphics.TBitMap; var err: string): boolean;

код ошибки GetLastError() = 6 // т.е. неверный дескриптор

а для очередной (наверное 8 разновидности получения мною скрина)

Function CaptureAnImage(WinH: HWND; var err: string): VCL.Graphics.TBitmap;
const
  CAPTUREBLT = $40000000;
var
  hdcScreen: HDC;
  hdcCompatible: HDC;
  hbmScreen: HBITMAP;
begin
  result := NIL;
  // Create a normal DC and a memory DC for the entire screen. The
  // normal DC provides a "snapshot" of the screen contents. The
  // memory DC keeps a copy of this "snapshot" in the associated
  // bitmap.
  hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
  if hdcScreen = 0 then
  begin
    err := Format('"CreateDC(DISPLAY)" Error: %d', [GetLastError()]);
    exit;
  end;

  hdcCompatible := CreateCompatibleDC(hdcScreen);
  if hdcCompatible = 0 then
  begin
    err := Format('"CreateCompatibleDC(hdcScreen)" Error: %d',
      [GetLastError()]);
    DeleteDC(hdcScreen);
    exit;
  end;

  // Create a compatible bitmap for hdcScreen.
  hbmScreen := CreateCompatibleBitmap(hdcScreen, GetDeviceCaps(hdcScreen,
    HORZRES), GetDeviceCaps(hdcScreen, VERTRES));
  if hbmScreen = 0 then
  begin
    err := Format('"CreateCompatibleBitmap(hdcScreen, ..." Error: %d',
      [GetLastError()]);
    DeleteDC(hdcScreen);
    DeleteDC(hdcCompatible);
    exit;
  end;

  // Select the bitmaps into the compatible DC.
  SelectObject(hdcCompatible, hbmScreen);
  result := TBitmap.Create;
  result.Handle := hbmScreen;
  if NOT BitBlt(hdcCompatible, 0, 0, result.Width, result.Height, hdcScreen, 0,
    0, SRCCOPY or CAPTUREBLT) then
  begin
    err := Format('"BitBlt(hdcCompatible, ..." Error: %d', [GetLastError()]);
    FreeAndNil(result);
  end;

  DeleteDC(hdcScreen);
  DeleteDC(hdcCompatible);
end;

при вызове BitBlt получаю снова ошибку ( GetLastError() с кодом ошибки 5 - Отказано в доступе)

Возможно кто-то знает нюансы использования злосчастной функции?

Решение этой траблы (получен серина на любой удаленной машине) у меня то есть: сервер приложения DataSnap в основном потоке в глобальной переменной типа битмап через 5 сек постоянно обновляет скрин. А серверный метод, при поступлении запроса от клиента, лишь сохраняет БитМап в создаваемый поток в памяти и возвращает его клиенту... Но это решение какое-то кривое....

[Dimitr69]

Короче та же трабла , что и
в теме
http://www.programmersforum.ru/showthread.php?t=1758

[Dimitr69]

Ну что, решение я нашел. И оно след:
Вам надо из вторичного потока получить стабильный скрин шот.
Чтож... мне точно известно, что его можно получить только если процедура получения скрина вызвана из основного потока.
Поэтому :
- из вторичного потока увеличиваем глоб переменную типа integer на 1
InterlockedIncrement(GlobalVarInteg er),
вызываем Sleep(200) циклично, проверяя, что бы GlobalVarInteger стал = 0

- из основного потока в методе Идл (TApplicationEvents.OnIdle), так же тестируем эту переменную, и если она стала >0 формируем скриншот, и записываем его в глоб переменную типа TBitMap, сбрасываем
GlobalVarInteger:= 0;

- во вторичном потоке произойдет выход из цикла и можно из глобального битмапа изображение сохранять на диск или передавать потоком куда дальше

с битмапом надо обращаться(из осн и вторичных потоков, если их несколько) через объекты синхорнизации (tCriticalsection или TMonitor.Enter(globalBMP)/TMonitor.Exit)