@DeeUs

Как сделать захват произвольной области экрана на нескольких мониторах (скриншот)?

Здравствуйте!
Пишу простой скриншотер с возможностью захвата произвольной области.
Столкнулся с проблемой - не удается реализовать работу программы с несколькими мониторами.
В чем выражается проблема:
При попытке сделать скриншот на втором мониторе - захватывается область на первом(как будто я сделал захват области на нём).
При попытке сделать скриншот на первом экране - Image1 "заливается" белым (прямоугольник выделенной области белого цвета)
Сразу приведу фрагменты кода, но на всякий случай приложил архив с проектом(+exe).
Кнопка "Сделать скриншот":
код

procedure TForm2.Button1Click(Sender: TObject);
var
  ScreenForm: TForm1;
begin
  // создаем полупрозрачную форму оверлей
  ScreenForm := TForm1.Create(nil);
  try
    // и растягиваем её на весь экран и позиционируем
    ScreenForm.Width := Screen.DesktopWidth;
    ScreenForm.Height := Screen.DesktopHeight;
    ScreenForm.Left := Screen.DesktopLeft;  // если 0 то программа работает только с 1 экраном - основным и корректно
    ScreenForm.Top := Screen.DesktopTop;    // если 0 то программа работает только с 1 экраном - основным и корректно
 
    // дальше прячем основную форму
    self.Hide;
    Application.ShowMainForm := FALSE;
 
    //показать форму оверлей
    ScreenForm.ShowModal;
 
    Image1.Picture.BitMap := ScreenForm.Bild;
 
    ScrollBox1.HorzScrollBar.Range := Image1.Picture.Width;
    ScrollBox1.VertScrollBar.Range := Image1.Picture.Height;
    self.Show;
  finally
    ScreenForm.Free;
  end;
end;


Захват области(+"исправление" прямоугольника выделенной области, если вдруг выделяли "снизу вверх"):
код

procedure NormRect(var aRect: TRect);
var tmp:Integer;
begin
if  aRect.Left > aRect.Right  then
    begin
      tmp:=aRect.Left;
      aRect.Left:=aRect.Right;
      aRect.Right:=tmp;
    end;
if  aRect.Top > aRect.Bottom  then
    begin
      tmp:=aRect.Top;
      aRect.Top:=aRect.Bottom;
      aRect.Bottom:=tmp;
    end;
end;
 
function CaptureScreenRect(aRect: TRect): TBitMap;
var
 ScreenDC: HDC;
 ActHandles:HWND;
begin
  Result := TBitMap.Create;
  with Result, aRect do
  begin
    Result.Free;
    Result := TBitMap.Create;
    NormRect(aRect); // исправить координаты выделенной области
    Result.Width := aRect.Right - aRect.Left;
    Result.Height :=aRect.Bottom - aRect.Top;
    ActHandles := GetDesktopWindow;
    ScreenDC  := GetWindowDC(ActHandles);//GetDc(0); - пробовал так, но результат тот же
    try
     BitBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height, ScreenDC, aRect.Left, aRect.Top, SRCCOPY);
    finally
     ReleaseDC(ActHandles, ScreenDC);//ReleaseDC(0, ScreenDC); - пробовал так, но результат тот же
    end;
  end;
end;


https://drive.google.com/file/d/1VSRkaWGla_TA7_4ft...
  • Вопрос задан
  • 99 просмотров
Пригласить эксперта
Ответы на вопрос 1
@DeeUs Автор вопроса
Решение оказалось очень простым))
Экспериментировал с координатами (ибо при работе на втором мониторе они отрицательные)
и сначала сделал так
(это прописано в onmouseup, но по сути r это aRect в функции CaptureScreenRect до применения NormRect)
r.Left := downX-screen.Width;
r.Top := downY;
r.Right := X-screen.Width;
r.Bottom := Y;

в таком случае работает корректно, но только если у меня мониторы выставлены в настройках как [2][1] (доп монитор у меня слева)
если я в настройках винды меняю порядок на [1][2](как будто я переставил доп монитор справа), то данное "исправление" не работает.

Но переделав фрагмент выше вот так вроде всё работает)
if Screen.DesktopLeft < 0 then
  begin
    r.Left := downX-screen.Width;
    r.Right := X-screen.Width;
  end
  else
  begin
  r.Left := downX;
    r.Right := X;
  end;
  if Screen.DesktopTop < 0 then
  begin
    r.Top := downY-screen.Height;
    r.Bottom := Y-screen.Height;
  end
  else
  begin
    r.Top := downY;
    r.Bottom := Y;
  end;


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

P.S.:
правда проверял только меняя настройки мониторов в винде (по другому не знаю как проверить):
[1][2]

[2][1]

[1]
[2]

[2]
[1]
Ответ написан
Ваш ответ на вопрос

Войдите, чтобы написать ответ

Войти через центр авторизации
Похожие вопросы
23 июн. 2021, в 15:19
1500 руб./в час
23 июн. 2021, в 15:13
70000 руб./за проект
23 июн. 2021, в 15:01
5000 руб./за проект