Screenshots erstellen. Canvas not allow to draw / Out of system resources

[gee21]

Hallo Ich möchte mit den beiden untenstehenden Proceduren/Functionen den Bildschirm auslesen mit Screenshots. (1+2 lesen den Desktop mit Mauszeiger aus und Nr3 liest Desktop ohne Mauszeiger aus). Funktioniert soweit alles wie gewünscht aber nach 5-30 Minuten kommen Fehlermeldungen.

Gemäss den Fehlermeldungen gibt es wohl Probleme bei zugriff von Handle/Canvas oder es wird wohl irgendetwas nicht mehr freigegeben. (vermute ich mal). ich habe diverses auf google dazu gefunden.(Canvas.lock, .free anstatt. destroy, ReleaseDC und bitmap freigeben nicht vergessen) leider konnte ich keine Lösung finden die für mich funktioniert hat. Und es ist etwas schwierig zu testen da es manchmal bis zu 30 min einwandfrei funktioniert.

Noch wichtig zu wissen: Ich rufe die Proceduren in einem Timer mit 200ms durchgehend ab.
Weiss jemand an was es liegen könnte? Und gibt es eine "einfache Lösung"?

Fehlermeldungen:

Code:

Maus Fehler: Falscher Parameter.
Maus Fehler: Falscher Parameter.
Maus Fehler: Falscher Parameter.
Maus Fehler: Out of system resources
Maus Fehler: Falscher Parameter.
Maus Fehler: Falscher Parameter.
Maus Fehler: Out of system resources
Maus Fehler: Falscher Parameter.
Maus Fehler: Out of system resources
Fehler: Screen 2 pic:Das Handle ist ungültig.
Fehler: Screen 2 pic:Out of system resources
Fehler: Screen 2 pic:Out of system resources
Fehler: Screen 2 pic:Out of system resources
Maus Fehler: Out of system resources
Maus Fehler: Das Handle ist ungültig.
Fehler: Screen 2 pic:Canvas does not allow drawing
Fehler: Screen 2 pic:Out of system resources
Fehler: Screen 2 pic:Out of system resources
Fehler: Screen 2 pic:Out of system resources
Maus Fehler: Out of system resources
Maus Fehler: Das Handle ist ungültig.

Geht dann immer so weiter.

Delphi-Quellcode:

// 1. Get the handle to the current mouse-cursor and its position
function GetCursorInfo2: TCursorInfo;
var
 hWindow: HWND;
 pt: TPoint;
 pIconInfo: TIconInfo;
 dwThreadID, dwCurrentThreadID: DWORD;
begin
  try
 Result.hCursor := 0;
 ZeroMemory(@Result, SizeOf(Result));
 // Find out which window owns the cursor
 if GetCursorPos(pt) then
 begin
   Result.ptScreenPos := pt;
   hWindow := WindowFromPoint(pt);
   if IsWindow(hWindow) then
   begin
     // Get the thread ID for the cursor owner.
     dwThreadID := GetWindowThreadProcessId(hWindow, nil);

     // Get the thread ID for the current thread
     dwCurrentThreadID := GetCurrentThreadId;

     // If the cursor owner is not us then we must attach to
     // the other thread in so that we can use GetCursor() to
     // return the correct hCursor
     if (dwCurrentThreadID <> dwThreadID) then
     begin
       if AttachThreadInput(dwCurrentThreadID, dwThreadID, True) then
       begin
         // Get the handle to the cursor
         Result.hCursor := GetCursor;
         AttachThreadInput(dwCurrentThreadID, dwThreadID, False);
       end;
     end
     else
     begin
       Result.hCursor := GetCursor;
     end;
   end;
 end;
 except on e: exception do addline('Fehler getcursorinfo2:'+e.Message);  end;
 end;

// 2. Capture the screen
procedure CaptureScreen (ImageKomp: TBitmap);
var
 DC: HDC;
 ABitmap: TBitmap;
 MyCursor: TIcon;
 CursorInfo: TCursorInfo;
 IconInfo: TIconInfo;
 MausPos: TPoint;
begin
try
 // Capture the Desktop screen
 DC := GetDC(GetDesktopWindow);
 ABitmap := TBitmap.Create;
 try
   ABitmap.Width  := 25;// GetDeviceCaps(DC, HORZRES);
   ABitmap.Height := 25;// GetDeviceCaps(DC, VERTRES);
   // BitBlt on our bitmap

   GetCursorPos(MausPos);

   BitBlt(ABitmap.Canvas.Handle,
     0,
     0,
     ABitmap.Width,
     ABitmap.Height,
     DC,
     MausPos.x - form1.Image_maus.Width div 2, //left
     MausPos.y - form1.Image_maus.height div 2,//top
     SRCCOPY);
   // Create temp. Icon
   MyCursor := TIcon.Create;
   try
     // Retrieve Cursor info
     CursorInfo := GetCursorInfo2;
     if CursorInfo.hCursor <> 0 then
     begin
       MyCursor.Handle := CursorInfo.hCursor;
       // Get Hotspot information
       GetIconInfo(CursorInfo.hCursor, IconInfo);
     // Draw the Cursor on our bitmap
       ABitmap.Canvas.Draw( -20-IconInfo.xHotspot,
                            -15-IconInfo.yHotspot, MyCursor);
     end;
   finally
     // Clean up
     MyCursor.ReleaseHandle;
     MyCursor.Free;
   end;

   form1.image_maus.picture.bitmap:=abitmap;
 finally
   ReleaseDC(GetDesktopWindow, DC);
   abitmap.Free;
 end;

except on e:exception do addline('Maus Fehler: '+e.Message); end;

end;

Delphi-Quellcode:

//3 Screenshot ohne Mauszeiger
procedure ScreenToImage( hoch: integer; breit: integer; oben:integer; links:integer; picturebild:timage);
var 
   Bitmap: TBitmap;
   Canvas: TCanvas;
begin
  try
   Canvas := TCanvas.Create;
   Canvas.Lock;
   try
     Canvas.Handle := GetWindowDC(0);
     try
       picturebild.Picture:=nil;
       Bitmap :=  TBitmap.Create;
       try
         Bitmap.Width := breit;
         Bitmap.Height:= hoch;
         Bitmap.PixelFormat := pf32bit;
         BitBlt(Bitmap.Canvas.Handle, 0, 0, Pred(Screen.DesktopWidth), Pred(
         Screen.DesktopHeight), Canvas.Handle, Screen.DesktopLeft+links,
         Screen.DesktopTop+oben, Bitmap.Canvas.CopyMode);
         picturebild.Picture.assign(bitmap);
       finally
        Bitmap.Free;
       end;
     finally
       ReleaseDC(0, Canvas.Handle);
     end;
   finally
     canvas.Unlock;//im internet gefunden. hilft aber nicht
   Canvas.Free;
   end;
   except on e: exception do addline('Fehler: Screen 2 pic:'+e.message); end;
end;

[klaus schaaff]

Hallo Robert,

schuld ist wahrscheinlich die Garbage Collection (Aufräumarbeiten des Arbeitsspeichers im System). Niemand kann sagen, wann diese exakt erfolgt.

In Deinem Fall bei procedure CaptureScreen wird bei jedem Duchlauf ein neues TBitmap erzeugt und irgendwann wieder vom System freigegeben. Es genügt nur mit einem TBitmap zu arbeiten. Das kann eine globale Variable sein oder oder eine Variable von TForm. Diese sollte nur einmal in Form.OnCreate -> aBitmap:= TBitmap.Create erzeugt werden und in Form.OnDestroy -> aBitmap.Free freigegeben werden. In procedure CaptureScreen wird nur noch aBitmap.Width und aBitmap.Height gesetzt mit

if aBitmap.With <> Breit then begin
aBitmap.With:= Breit;
end;
if aBitmap.Height <> Hoch then begin
aBitmap.Height:= Hoch;
end;

Ein TBitmap.Canvas.Lock verhindert eher anstehende Aufräumarbeiten.

Teste mal das, indem Du nur mit einem Bitmap arbeitest und nur procedure CaptureScreen verwendest ohne Maus Capture!


Liebe Grüße
Klaus Schaaff

[gee21]

Zitat von klaus schaaff:

Hallo Robert,

schuld ist wahrscheinlich die Garbage Collection (Aufräumarbeiten des Arbeitsspeichers im System). Niemand kann sagen, wann diese exakt erfolgt.

In Deinem Fall bei procedure CaptureScreen wird bei jedem Duchlauf ein neues TBitmap erzeugt und irgendwann wieder vom System freigegeben. Es genügt nur mit einem TBitmap zu arbeiten. Das kann eine globale Variable sein oder oder eine Variable von TForm. Diese sollte nur einmal in Form.OnCreate -> aBitmap:= TBitmap.Create erzeugt werden und in Form.OnDestroy -> aBitmap.Free freigegeben werden. In procedure CaptureScreen wird nur noch aBitmap.Width und aBitmap.Height gesetzt mit

if aBitmap.With <> Breit then begin
aBitmap.With:= Breit;
end;
if aBitmap.Height <> Hoch then begin
aBitmap.Height:= Hoch;
end;

Ein TBitmap.Canvas.Lock verhindert eher anstehende Aufräumarbeiten.

Teste mal das, indem Du nur mit einem Bitmap arbeitest und nur procedure CaptureScreen verwendest ohne Maus Capture!


Liebe Grüße
Klaus Schaaff

Vielen Dank Schaaff. Habe das gemäss deinem Vorschlag abgeändert. Nach 2-3 Tagen testen kann ich sagen das es nicht mehr aufgetreten ist daher denke ich das es das war, nun läufts. TOP

[himitsu]

Wie groß sind die Bilder?
Nicht sehr klein.

Zitat:

Delphi-Quellcode:

if aBitmap.With <> Breit then
  aBitmap.With:= Breit;
if aBitmap.Height <> Hoch then
  aBitmap.Height:= Hoch;

Statt Width und Height einzeln, kommt SetSize oft besser, da die Beiden das intern sowieso aufrufen, also 2 Mal.

Delphi-Quellcode:

if (aBitmap.With <> Breit)  or (aBitmap.Height <> Hoch) then
  aBitmap.SetSize(Breit, Hoch);

und da

Zitat:

Delphi-Quellcode:

procedure TBitmap.SetSize(AWidth, AHeight: Integer);
var
  DIB: TDIBSection;
begin
  HandleNeeded;
  with FImage do
    if (FDIB.dsbm.bmWidth <> AWidth) or (FDIB.dsbm.bmHeight <> AHeight) then
  ...


procedure TBitmap.SetWidth(Value: Integer);
begin
  SetSize(Value, FImage.FDIB.dsbm.bmHeight);
end;

nur noch einmal
aBitmap.SetSize(Breit, Hoch);

[gee21]

Zitat:

Wie groß sind die Bilder?

die meisten sind 5x5 Pixel oder 12x12 Pixel. Eines ist jedoch grösser ca 25x600 Pixel.
Das grosse Bild werde ich nun entfernen und eine andere Lösung suchen um schneller zu sein.

Zitat:

aBitmap.SetSize(Breit, Hoch);

Ah ja das ist besser, danke. Habe ich so eingebaut.



Allgemein muss ich leider sagen obwohl ich die Proceduren in den letzten Tagen verkleinert / vereinfacht habe, ist der Fehler leider immer noch vorhanden.

Es ist im Moment nicht so schlimm da ich eine Restarter.exe geschrieben habe, die im Fall eines Absturz die Problem.exe einfach wieder neu startet. Wo aber das Problem genau passiert ist mir leider immer noch nicht klar.

Lustigerweise ist der Absturz oftmals ziemmlich genau nach 30 min +/- 5 Minuten. Was mich ein wenig verwirrt da ich manchmal mit einem Timer intervall von 200ms laufen lasse und manchmal mit 50ms. Da müsste sich doch die Absturzzeit auch verändern. Tut es aber glaube ich nicht.

Ich werde nun noch ein paar Tage rum testen und falls ich nichts rausfinde, werde ich den aktuellen angepassten code nochmals posten.

Frage ist es möglich das ein Timer eine Procedure zu schnell startet? das zB immer das .create ausgeführt wird aber das .free aufgrund des timer neustarts nicht mehr? (.free ist im finally block)

[Delphi.Narium]

Was ist denn, wenn der Timer bereits wieder auslöst, wenn die von ihm aufgerufenen Routine noch nicht zuende gearbeitet hat?

Bei mir wird in den OnTimer-Routinen zuerst immer der Timer ausgeschaltet, dann gearbeitet, dann der Timer eingeschaltet.

Delphi-Quellcode:

procedure TIrgendwas.TimerTimer(sender :TObject);
begin
  Timer.Enabled := false;
  // Hier wird gearbeitet, andere Routinen aufgerufen ...
  Timer.Enabled := true;
end;

Da dadurch kein konstantes Timerintervall mehr möglich ist, wird Timer.Interval immer neu berechnet, so dass das Auslösen des Timers trotzdem immer "pünktlich" ist, allerdings hab' ich keine Routine, in der die Zeitspanne < 1 Sekunde ist. Sprich: In dem Fall löst der Timer jede volle Sekunde aus +/- dem kürzestmöglichen "Rechenfehler" beim Setzen von Timerintervallen unter Windows.

Analog zu demhier https://www.delphipraxis.net/1332933-post2.html könnte es so aussehen:

Delphi-Quellcode:

   ..
  Timer.Inteval :=  CalcTimerInterval(50);
  timer.Enabled := True;
  .. // bzw. 
  Timer.Inteval :=  CalcTimerInterval(200);
  timer.Enabled := True;
  ..

Braucht die Routine länger als die gewünschte Zeit von 50 oder 200 Millisekunden, so wird der Timer auf den nächsten passenden "Startwert" gesetzt. Dadurch können zwar in der Ausführung Lücken von 50 bzw. 200 Millisekunden (bzw. deren Vielfaches) entstehen, aber das Ereignis wird nicht bereits wieder ausgelöst, während das letzte Ereignis noch abgearbeitet wird. (Und das von Dir beschriebene Verhalten lässt schwer genau darauf schließen.)

[KodeZwerg]

Du kannst auch gerne mal meine SnapShot Klasse testen ob es das macht was Du möchtest, bisher hatte ich keine Probleme damit allerdings habe ich nicht integriert das der Mauspfeil mitgeknippst wird.