мерцание при скрин шотинге

[DenProx]

Доброго времени суток. У меня такой вопрос: делаю программу для мониторинга рабочих столов на мультимониторной системе. Т.е. стоит 3 монитора, главный и два дополнительных, на главном необходимо наблюдать за тем что происходит на дополнительных. Вот код программы:

function GrabDesktop(var bmp: TBitmap; MonitorNumber: Integer): Boolean;
const
CAPTUREBLT = $40000000;
var
DesktopCanvas: TCanvas;
DC: HDC;
Left, Top: Integer;
begin
Result := False;
 
if (MonitorNumber > Screen.MonitorCount) then
Exit;
 
DC := GetDC(0);
try
if (DC = 0) then
Exit;
 
if (MonitorNumber = 0) then
begin
bmp.Width := Screen.DesktopWidth;
bmp.Height := Screen.DesktopHeight;
Left := Screen.DesktopLeft;
Top := Screen.DesktopTop;
end
else
begin
bmp.Width := Screen.Monitors[MonitorNumber-1].Width;
bmp.Height := Screen.Monitors[MonitorNumber-1].Height;
Left := Screen.Monitors[MonitorNumber-1].Left;
Top := Screen.Monitors[MonitorNumber-1].Top;
end;
 
DesktopCanvas := TCanvas.Create;
try
DesktopCanvas.Handle := DC;
 
Result := BitBlt(
bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,
DesktopCanvas.Handle,Left,Top,SRCCOPY or CAPTUREBLT
);
finally
DesktopCanvas.Free;
end;
finally
if (DC <> 0) then
ReleaseDC(0, DC);
end;
end;
 
procedure CaptureScreen(Bitmap: TBitmap);
const
CAPTUREBLT = $40000000;
var
hdcScreen: HDC;
hdcCompatible: HDC;
bmp: TBitmap;
hbmScreen: HBITMAP;
begin
 
hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
hdcCompatible := CreateCompatibleDC(hdcScreen);
 
hbmScreen := CreateCompatibleBitmap(hdcScreen,
GetDeviceCaps(hdcScreen, HORZRES),
GetDeviceCaps(hdcScreen, VERTRES));
 
SelectObject(hdcCompatible, hbmScreen);
 
bmp := TBitmap.Create;
grabDesktop(bmp,2);
 
Bitmap.Assign(bmp);
bmp.Free;
 
DeleteDC(hdcScreen);
DeleteDC(hdcCompatible);
 
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
if Timer1.Enabled = True then Timer1.Enabled := False else
Timer1.Enabled := True;
end;
 
procedure TForm1.Timer1Timer(Sender: TObject);
begin
CaptureScreen(Image1.Picture.Bitmap);
end;

Все работает. НО! Недочет в том что, при активации просмотра (Timer = True) , изображение начинает мерцать, что напрягает глаза сильно... можно ли с этим как то бороться? частоту таймера менял от 25 до 1000 ... мерцание не пропадало.

[psycho-coder]

Попробуй через буфер т.е. Сохраняешь изображение в переменную а потом выводишь в Image1

Ну, как то так:

private
  FScreen: TBitmap;
...
procedure TForm1.Timer1Timer(Sender: TObject);
begin
CaptureScreen(FScreen);
Image1.Picture.Bitmap := FScreen;
end;

У TImage есть вроде свойство DoubleBuffer, не лишним будет его включить.

[DenProx]

У TImage есть вроде свойство DoubleBuffer, не лишним будет его включить.

нету... только что проверил

а код такой не хочет работать(

[mss]

> частоту таймера менял от 25 до 1000

Не надо пороть чушь.
Максимальная частота обычного таймера равна примерно 18 гц.

[DenProx]

я говорю то что пробовал... а какая частота у него, я и так знаю. Это значения которые я выставлял в Interval у Timer'a ...

[DenProx]

Есть другой код, он тоже скриншотит экран, но он с недочетом... память грузит, да и не эффективно работает... но плюс его в том что нет мерцания, вот код:

procedure TfmMon1.TimerTimer(Sender: TObject);
var Srect,Drect,PosForme:TRect;
	iWidth,iHeight:Integer;
  iTmpX,iTmpY:Real;
  C:TCanvas;
	Kursor:TPoint;
  DC: hDC;

begin
try
 If not PtInRect(PosForme,Kursor) then
  begin
    If Image.Visible=False then Image.Visible:=True;

 	   iWidth:=Image.Width;
		 iHeight:=Image.Height;
     Drect:=Rect(0,0,iWidth,iHeight);

      iTmpX:= W/2;
      iTmpY:= H/2;

    Srect:=Rect(0,0,0,0);
    InflateRect(Srect,Round(iTmpX),Round(iTmpY));

    If Srect.Left<0 then OffsetRect(Srect,tWm1,0);
    If Srect.Top<0 then OffsetRect(Srect,tHm1,-Srect.Top);

		 C:=TCanvas.Create;
		 try
			 C.Handle:=GetDC(GetDesktopWindow);
 		 Image.Canvas.CopyRect(Drect,C,Srect);
    finally
			 C.Free;
    end;
  end;
except
Exit;
MessageDlg('Непредвиденная ошибка!',mtError,[mbOK],0);
end;
end;

[psycho-coder]

Вот добавь инициализацию FScreen

...
procedure TForm1.FormCreate(Sender: TObject);
begin
  FScreen := TBitmap.Create;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  CaptureScreen(FScreen);
  Image1.Picture.Bitmap := FScreen;
end;

[DenProx]

psycho-coder теперь работает, но все равно мерцает...

[psycho-coder]

Тогда, даже не знаю что посоветовать, у меня все нормально работает, с/без переменной.
upd
Вспомнил еще кое что)) Можно попробовать включить AlphaBlend на форме, иногда помогает избежать мерцания