线程中 TBitmap 操作，报错“Out of system resources”？

Question

在网上找了个 Delphi 的远程桌面代码，但是 跑着跑着，发送图片的线程就异常退出了... 调试了一下，发现貌似是 线程中操作 TBitmap 的缘故 ，想请教下是为什么？？如下是我的测试代码，已经弄得比较简单了：主界面Form1中的代码：procedure TForm1.Button1Click(Sender: TObject);
var bmp:TBitMap;
    DC:HDC;
    ms:TMemoryStream;
    i:integer;
begin
  ms:=TMemoryStream.Create;
  DC := GetDC(0);
  bmp:=TBitMap.Create;
  bmp.Width  := 64;
  bmp.Height := 64;
  bmp.PixelFormat:= pf8bit;  for i:=0 to 10000 do
  begin
    BitBlt(bmp.Canvas.Handle, 0, 0, 64, 64, DC, 0, 0, SRCCOPY);
    ms.Clear;
    bmp.SaveToStream(ms);
  end;
  Memo1.Lines.Add(inttostr(ms.Size));  ReleaseDC(0, DC);
  ms.Free;
  bmp.Free;
end;procedure TForm1.Button2Click(Sender: TObject);
var TestThread:TTestThread;
begin
  TestThread:=TTestThread.Create(false);
end;线程中代码：procedure TTestThread.Execute;
var bmp:TBitmap;
    DC:HDC;
    ms:TMemoryStream;
    i:integer;
begin
  ms:=TMemoryStream.Create;
  DC := GetDC(0);
  bmp:=TBitmap.Create;
  bmp.Width  := 64;
  bmp.Height := 64;
  bmp.PixelFormat:= pf8bit;  for i:=0 to 10000 do
  begin
    try
      Bmp.Canvas.Lock;
      BitBlt(bmp.Canvas.Handle, 0, 0, 64, 64, DC, i, i, SRCCOPY);
      Bmp.Canvas.UnLock;
      ms.Clear;
      bmp.SaveToStream(ms);
      Form1.Memo1.Lines.Add(inttostr(i)+' - '+inttostr(ms.Size));
    except on E:Exception do
      Form1.Memo1.Lines.Add(E.Message);
    end;
  end;  ReleaseDC(0, DC);
  ms.Free;
  bmp.Free;  Form1.Memo1.Lines.Add('Thread Over');
end;点击 Button1 ，运行一切正常。点击 Button2 ，for 中跑着跑着就会 报错：“Out of system resources”，加了Bmp.Canvas.Lock;和Bmp.Canvas.UnLock; 也一样，for 中次数多了 就报错了...请问如何解决？？

Answer 1

for i:=0 to 10000 do，是不是bmp太大了，已经没有空间分配了

Answer 2

反复 “BitBlt(bmp.Canvas.Handle, 0, 0, 64, 64, DC, i, i, SRCCOPY);” 会增加 bmp 的大小吗？
为什么 我这句 “Form1.Memo1.Lines.Add(inttostr(i)+' - '+inttostr(ms.Size));”打印出来的结果，bmp并没有增加？？
点击 Button2 后，Memo出现：0 - 5174
1 - 5174
2 - 5174
3 - 5174
4 - 5174
5 - 5174
6 - 5174
7 - 5174
8 - 5174
9 - 5174
..........
995 - 5174
996 - 5174
997 - 5174
998 - 5174
999 - 5174
1000 - 5174
Out of system resources
Out of system resources
Out of system resources
Out of system resources
Out of system resources
Out of system resources
Out of system resources
.......
Out of system resources
Out of system resources
Thread Over

Answer 3

這樣呢
unit Unit1;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,jpeg,StdCtrls, ExtCtrls; //截取屏幕时要用到jpeg对象保存图像数据type
TForm1 = class(TForm)
    Image1: TImage;
    procedure Image1Click(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;var
Form1: TForm1;
jpegscreen:Tjpegimage;implementation{$R *.dfm}
procedure ScreenCap(LeftPos,TopPos,RightPos,BottomPos:integer);
var
bmpscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
sourceRect, destRect: TRect;
begin
dc:=getdc(0);
fullscreencanvas:=Tcanvas.Create;
fullscreencanvas.Handle:=dc;
bmpscreen:=Tbitmap.create;
bmpscreen.Width :=screen.Width ;
bmpscreen.Height :=screen.Height ;
sourcerect:=rect(0,0,screen.Width ,screen.Height );
destrect:= rect(0,0,screen.Width ,screen.Height);
bmpscreen.Canvas.CopyRect(sourcerect,fullscreenCanvas,destrect);                                //使用copyrect方法把屏幕canvas中的数据复制到jpeg中
jpegscreen:=Tjpegimage.Create;
jpegscreen.Assign (bmpscreen);
jpegscreen.CompressionQuality:=40;
FullscreenCanvas.Free;
bmpscreen.Free;
ReleaseDC(0, DC);
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
ScreenCap(0,0,screen.width,screen.height);
image1.Picture.Bitmap.Assign(jpegscreen);
jpegscreen.Free ;
end;end.

Answer 4

LZ你的情况跟我原来的一样 内存不够了 10000太大了 我的用了2000多就崩溃了
你可以看看任务管理器 你的程序内容使用肯定特别高
你最好把PixelFormat设置到最低 这样可能会好些
我原来也发过类似的帖子

Answer 5

我线程里改成这样：procedure TTestThread.Execute;
var bmp:TBitmap;
    DC:HDC;
    ms:TMemoryStream;
    i:integer;    fullscreencanvas:Tcanvas;
    sourceRect, destRect: TRect;
begin
  ms:=TMemoryStream.Create;
  DC := GetDC(0);
  bmp:=TBitmap.Create;
  bmp.Width  := 64;
  bmp.Height := 64;
  bmp.PixelFormat:= pf8bit;  fullscreencanvas:=Tcanvas.Create;
  fullscreencanvas.Handle:=DC;
  sourcerect:=rect(0,0,64 ,64 );
  destrect:= rect(0,0,64 ,64);  for i:=0 to 10000 do
  begin
    try
      Bmp.Canvas.Lock;
      Bmp.Canvas.CopyRect(sourcerect,fullscreenCanvas,destrect);  // 这里 修改了
//      BitBlt(bmp.Canvas.Handle, 0, 0, 64, 64, DC, i, i, SRCCOPY);
      Bmp.Canvas.UnLock;
      ms.Clear;
      bmp.SaveToStream(ms);
      Form1.Memo1.Lines.Add(inttostr(i)+' - '+inttostr(ms.Size));
    except on E:Exception do
      Form1.Memo1.Lines.Add(E.Message);
    end;
  end;  ReleaseDC(0, DC);
  ms.Free;
  bmp.Free;  fullscreencanvas.Free;  Form1.Memo1.Lines.Add('Thread Over');
end;
一样的错误啊...

Answer 6

顏色值太高，太吃內存了。
按照樓上修正下PixelForma呢

Answer 7

修正PixelFormat ，这个办法也太那个了吧... 本来设的值就不高啊...我从Memo的输出没看出bmp的增长啊 ？？？...... 那能不能有清除 bmp内容的方式？？貌似 加了 bmp.FreeImage 也一样报错...

Answer 8

try
   BitMap1.LoadFromFile('c:\Program Files\common Files\Borland Shared\Images\Splash\256color\factory.bmp');
   BitMap2.Assign(BitMap1);     // Copy BitMap1 into BitMap2
   BitMap2.Dormant;             // Free up GDI resources
   BitMap2.FreeImage;           // Free up Memory.
   Canvas.Draw(20,20,BitMap2);  // Note that previous calls don't lose the image   BitMap2.Monochrome := true;
   Canvas.Draw(80,80,BitMap2);
   BitMap2.ReleaseHandle;       // This will actually lose the bitmap;
 finally
   BitMap1.Free;
   BitMap2.Free;
 end;摘抄自帮助.
我那个程序里跟画东西比较多 所以我的是2000个就崩溃了 

Answer 9

在線程中不能直接操作主線程的VCL界面，下句放在線程中是錯誤的。
 Form1.Memo1.Lines.Add(inttostr(i)+' - '+inttostr(ms.Size));
應放在一個過程中操作，然後用synchronize調用。如：
procedure ProName;
begin
Form1.Memo1.Lines.Add(inttostr(i)+' - '+inttostr(ms.Size));
end;
在線程中按如下調用：
synchronize(ProName);

Answer 10

//我的程序处理
begin
    pBit.Dormant;
    pBit.FreeImage;
    JPEGMap := TJPEGImage.create;
    JPEGMap.Assign(pBit);
end;这是我那个程序处理的我最后是把PixelFormat 设置的低一些，
然后用TJPEGImage来保存BitMap的内容，就基本上避免了崩溃的事
不过还是不能太多，因为毕竟内存有限

Answer 11

bmp.SaveToStream(ms);
Bmp.Canvas.UnLock;
调个位置

Answer 12

看了下savetostream的源码，里面也有对canvas的操作。

Answer 13

是的，你只要讲Unlock调到SaveToStream下面就可以了。
03年的时候在大富翁论坛上有讨论的。