Delphi EOutOfResources Захват экрана

Question

Программа, которая дает эту ошибку. Иногда сразу, иногда через короткий промежуток времени

http://www1.datafilehost.com/d/39f524c0 Thread Приостановка в некоторые пытаются наконец блокировать

Источник:

http://www1.datafilehost.com/d/1cae7b24 EOufOfResources Во время отладки

Im извините за плохой английский. У меня есть следующая проблема: я пытаюсь сделать скриншоты 5 кадров в секунду и нарисовать на них значок курсора, перекодировать BMP в PNG и отправить его по сети через блокирующие розетки Indy. После отправки снимка, пропорционально сжатого и помещенного на TImage (desktopimage) в основной форме. Если я делаю все это по таймеру - все работает нормально, если я выполняю весь этот код в Synchronize(), он также отлично работает, но он вызывает замораживание интерфейса, я хочу избавиться от него и делать поэтому в сжатии PNG в потоке теперь я попытался сломать несколько Synchronize(), чтобы найти ошибку (я получаю сообщение об ошибке EOutOfResources), но я не мог. Пожалуйста помоги. Вот мой код:

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

Решил проблему. Написал код в Synchronize(), за исключением сжатия PNG и перед использованием сжатого метода Canvas.Lock после сжатия Canvas.UnLock. Это позволяет избежать влияния другого потока на Canvas. Спасибо за совет bummi (TCanvas не является поточным). Правильно Execute метод находится здесь:

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

Во-первых, в моем Delphi 2010 я должен заменить

unit CaptureUnit; 

interface 

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

с

unit CaptureUnit; 

interface 

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

То же самое в unit.pas

Не следует назначать a Растровое изображение до Picture.Assign(bmp);

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

Через короткое время я также получаю сообщение об ошибке EOutOfResources).

Вы должны назначить Bitmap для Picture.Bitmap.Assign(bmp);

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

после того, как я изменил его, я получил вашу программу бег в течение 20 минут, не получив ошибку. Затем я закончил его вручную.

Update:

Скриншот: программа работает в то время как Vcl Проигрывание видео и растяжения и перемещения захвата района.

Надеется, что это помогает.