Screen Capture Delphi EOutOfResources

Question

A program that gives this error. Sometimes immediately, sometimes in a short time

http://www1.datafilehost.com/d/39f524c0 Thread Pause some attempts, finally block

A source:

http://www1.datafilehost.com/d/1cae7b24 EOufOfResources During debugging

I'm sorry for the bad english. I have the following problem: I'm trying to take screenshots of 5 frames per second and draw a cursor icon on them, transcode BMP to PNG and send it over the network via Indy blocking sockets. After sending the image, proportionally compressed and placed on the TImage (desktopimage) in the main form. If I do it all on a timer - everything works fine, if I execute all this code in Synchronize (), it also works fine, but it causes the interface to freeze, I want to get rid of it and therefore do PNG compression in the stream now I tried break a few Synchronize () to find the error (I get an EOutOfResources error message), but I could not. Please help. Here is my code:

TCaptureThread = class(TThread) private bmp: TBitmap; DC: HDC; h:hwnd; thumbRect : TRect; maxWidth, maxHeight:integer; png:TPNGImage; Stream:TMemoryStream; RecBlock:TCommBlock; r: TRect; CI: TCursorInfo; Icon: TIcon; II: TIconInfo; commblock:TCommblock; procedure showthumb; procedure send; procedure stretch; procedure getscreen; procedure fixsize; protected procedure Execute; override; constructor Create(CreateSuspended: Boolean); destructor destroy; override; end; constructor TCaptureThread.Create(CreateSuspended: Boolean); begin bmp:=TBitmap.Create; Stream:=TMemoryStream.Create; png:=TPNGImage.Create; Icon := TIcon.Create; inherited Create(CreateSuspended); end; destructor TCaptureThread.destroy; begin png.Free; bmp.Free; Icon.Free; stream.Free; inherited; end; procedure TCaptureThread.Execute; begin inherited; while not Terminated do begin Synchronize(fixsize); Synchronize(getscreen); r := bmp.Canvas.ClipRect; try CI.cbSize := SizeOf(CI); if GetCursorInfo(CI) then if CI.Flags = CURSOR_SHOWING then begin Icon.Handle := CopyIcon(CI.hCursor); if GetIconInfo(Icon.Handle, II) then begin bmp.Canvas.Draw( ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left - Form4.Left, ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top - Form4.Top, Icon ); end; end; finally end; try png.Assign(bmp); png.CompressionLevel := 9; png.SaveToStream(stream); stream.Position :=0; Recblock.Command :='STREAM'; Recblock.Msg :=''; Recblock.NameFrom := MyName; Synchronize(send); finally end; try thumbRect.Left := 0; thumbRect.Top := 0; if bmp.Width > bmp.Height then begin thumbRect.Right := maxWidth; thumbRect.Bottom := (maxWidth * bmp.Height) div bmp.Width; end else begin thumbRect.Bottom := maxHeight; thumbRect.Right := (maxHeight * bmp.Width) div bmp.Height; end; Synchronize(stretch); bmp.Width := thumbRect.Right; bmp.Height := thumbRect.Bottom; Synchronize(showthumb); finally end; sleep(200); end; end; procedure TCaptureThread.getscreen; begin DC:=GetDC(0); bitblt(bmp.Canvas.Handle, 0, 0, Form4.Width+Form4.Left, Form4.Height+Form4.Top, DC, Form4.Left, Form4.Top, SRCCOPY); ReleaseDC(0, DC); end; procedure TCaptureThread.fixsize; begin maxWidth := Form1.DesktopImage.Width; maxHeight := Form1.DesktopImage.Height; bmp.Height:=Form4.Height; bmp.Width:=Form4.Width; end; procedure TCaptureThread.send; begin Form1.Streamclient.IOHandler.Write(RawToBytes(Recblock,sizeof(recblock)),sizeof(recblock)); Form1.Streamclient.IOHandler.Write(stream,stream.Size,true); end; procedure TCaptureThread.showthumb; begin Form1.DesktopImage.Picture.Assign(bmp); end; procedure TCaptureThread.stretch; begin SetStretchBltMode(bmp.Canvas.Handle, HALFTONE); StretchBlt(bmp.Canvas.Handle,0,0,thumbRect.Right,thumbRect.Bottom,bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,SRCCOPY); end; 

Answer 1

Solved a problem. I wrote code in Synchronize() , in addition to PNG compression, and before compression used the Canvas.Lock method, after Canvas.UnLock compression. This avoids the effect of another thread on the Canvas . Thanks for the bummi tip (TCanvas is not threaded). The correct Execute method is here:

 procedure TCaptureThread.Execute; begin inherited; while not Terminated do begin Synchronize(size); Synchronize(getscreen); Synchronize(drawcursor); try png.Canvas.Lock; bmp.Canvas.Lock; png.Assign(bmp); png.CompressionLevel := 9; png.Canvas.Unlock; bmp.Canvas.Unlock; finally end; try Synchronize(stretch); Synchronize(showthumb); finally end; sleep(200); end; end; 

Answer 2

First in my delphi 2010 I have to replace

 unit CaptureUnit; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs; 

with

 unit CaptureUnit; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs; 

Same thing in unit.pas

Do not assign a bitmap Picture.Assign(bmp);

 procedure TCaptureThread.showthumb; begin CaptureForm.DesktopImage.Picture.Assign(bmp); end; 

After a short time, I also get the EOutOfResources error).

You must assign a bitmap to Picture.Bitmap.Assign(bmp);

 procedure TCaptureThread.showthumb; begin CaptureForm.DesktopImage.Picture.Bitmap.Assign(bmp); end; 

After I changed it, I ran your program for 20 minutes without receiving an error. Then I finished it manually.

Update:

Screenshot: Vcl program works while playing video, stretching and moving the capture area.

Hope this helps you.