好的,所以我对Delphi很陌生(正如你从我的代码中看到的那样 - 尽量不要笑得太厉害并且伤害自己),但我已经设法制作了一个小桌面画布颜色选择器。它有效,有点,这就是我在这里的原因:D
似乎在泄漏。它使用大约2 MB的内存开始,每秒爬升大约2 kB,直到10分钟左右达到大约10 MB。在我的双核2.7 ghz cpu上,它使用5%到20%的CPU功率,波动。在没有停止计时器的情况下运行约10分钟后,我的计算机没有响应。
您可以在下面的源代码中看到我正在释放TBitmap(或尝试,不确定它是否正在执行它,似乎没有工作)。
procedure TForm1.Timer1Timer(Sender: TObject);
begin
GetCursorPos(MousePos);
try
Canvas1 := TCanvas.Create;
Canvas1.Handle := GetDC(0);
Pxl := TBitmap.Create;
Pxl.Width := 106;
Pxl.Height := 106;
W := Pxl.Width;
H := Pxl.Height;
T := (W div 2);
L := (H div 2);
Zoom := 10;
Rect1 := Rect(MousePos.X - (W div Zoom), MousePos.Y - (H div Zoom), MousePos.X + (W div Zoom), MousePos.Y + (H div Zoom));
Rect2 := Rect(0, 0, H, W);
Pxl.Canvas.CopyRect(Rect2, Canvas1, Rect1);
Pxl.Canvas.Pen.Color := clRed;
Pxl.Canvas.MoveTo(T, 0);
Pxl.Canvas.LineTo(L, H);
Pxl.Canvas.MoveTo(0, T);
Pxl.Canvas.LineTo(W, L);
Image1.Picture.Bitmap := Pxl;
finally
Pxl.Free;
end;
try
Pxl2 := TBitmap.Create;
Pxl2.Width := 1;
Pxl2.Height := 1;
Box1 := MousePos.X;
Box2 := MousePos.Y;
BitBlt(Pxl2.Canvas.Handle, 0, 0, 1, 1, GetDC(0), Box1, Box2, SRCCOPY);
C := Pxl2.Canvas.Pixels[0, 0];
Coord.Text := IntToStr(Box1) + ', ' + IntToStr(Box2);
DelColor.Text := ColorToString(C);
HexColor.Text := IntToHex(GetRValue(C), 2) + IntToHex(GetGValue(C), 2) + IntToHex(GetBValue(C), 2);
RGB.Text := IntToStr(GetRValue(C)) + ', ' + IntToStr(GetGValue(C)) + ', ' + IntToStr(GetBValue(C));
Panel1.Color := C;
finally
Pxl2.Free;
end;
end;
procedure TForm1.OnKeyDown(Sender: TObject; var Key: Char);
begin
if Key = #13 then
begin
if Timer1.Enabled then
begin
Timer1.Enabled := false;
Panel2.Caption := 'Got it! Press Enter to reset.';
end
else
begin
Timer1.Enabled := true;
Panel2.Caption := 'Press Enter to lock color.';
end;
end;
end;
注意:定时器设置为每10毫秒运行一次,如果这有任何不同。
任何有助于弄清楚为何泄漏并使用如此多资源的人都会非常感激!
如果需要,可以在这里抓住项目(Delphi 2010):http://www.mediafire.com/file/cgltcy9c2s80f74/Color%20Picker.rar
谢谢!
答案 0 :(得分:5)
你永远不会释放你的Canvas1对象,泄漏进程堆和GDI obj。处理。
答案 1 :(得分:2)
如上所述,拥有桌面窗口DC的TCanvas实例从未释放,不释放DC。我在这里发现了另一个DC泄漏:
BitBlt(Pxl2.Canvas.Handle, 0, 0, 1, 1, GetDC(0), Box1, Box2, SRCCOPY);
^^^^^^^^
这不能解决内存泄漏问题,但可以解释为什么Windows在20分钟后无响应(假设上一个问题已经修补)
答案 2 :(得分:2)
好的,我找到了解决方案(最后),稍后修改了一下,然后按照这里的一些指示。没人真正击中它,但每个人都在正确的轨道上。问题是我在FUNCTION中调用GetDC()
(在早期版本中也调用了计时器过程)。将它移到“try ... finally”之外,同时将其保持在函数中(如建议的那样)仍然没有产生结果,但它已经接近并且给了我实际工作的想法。所以我把它移动了一点 - 进入Form的OnCreate
事件。
这是最终的代码:
function DesktopColor(const X, Y: Integer): TColor;
begin
Color1 := TCanvas.Create;
Color1.Handle := DC;
Result := GetPixel(Color1.Handle, X, Y);
Color1.Free;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
GetCursorPos(Pos);
Rect1 := Rect(Pos.X - (W div Zoom), Pos.Y - (H div Zoom), Pos.X + (W div Zoom), Pos.Y + (H div Zoom));
Rect2 := Rect(0, 0, H, W);
Pxl.Canvas.CopyRect(Rect2, Canvas1, Rect1);
Pxl.Canvas.Pen.Color := clRed;
Pxl.Canvas.MoveTo(T, 0);
Pxl.Canvas.LineTo(L, H);
Pxl.Canvas.MoveTo(0, T);
Pxl.Canvas.LineTo(W, L);
Image1.Picture.Bitmap := Pxl;
Coord.Text := IntToStr(Pos.X) + ', ' + IntToStr(Pos.Y);
C := DesktopColor(Pos.X, Pos.Y);
DelColor.Text := ColorToString(C);
HexColor.Text := IntToHex(GetRValue(C), 2) + IntToHex(GetGValue(C), 2) + IntToHex(GetBValue(C), 2);
RGB.Text := IntToStr(GetRValue(C)) + ', ' + IntToStr(GetGValue(C)) + ', ' + IntToStr(GetBValue(C));
Panel1.Color := C;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Pxl := TBitmap.Create;
Canvas1 := TCanvas.Create;
DC := GetDC(0);
Pxl.Width := 106;
Pxl.Height := 106;
Canvas1.Handle := DC;
W := Pxl.Width;
H := Pxl.Height;
T := (W div 2);
L := (H div 2);
Zoom := 10;
Timer1.Enabled := True;
end;
procedure TForm1.OnKeyDown(Sender: TObject; var Key: Char);
begin
if Key = #13 then
begin
if Timer1.Enabled then
begin
Timer1.Enabled := false;
Panel2.Caption := 'Got it! Press Enter to reset.';
end
else
begin
Timer1.Enabled := true;
Panel2.Caption := 'Press Enter to lock color.';
end;
end;
end;
procedure TForm1.OnDestroy(Sender: TObject);
begin
ReleaseDC(0, Canvas1.Handle);
ReleaseDC(0, Color1.Handle);
end;
最后的计数: 鼓声 CPU使用率:00%空闲,如果你足够快地移动鼠标,则会出现01%的峰值;内存使用量:~3,500 kB solid,保持不变。我甚至将定时器从10毫秒提升到5毫秒,仍然得到相同的数字。
这是包含所有上述修复的最终项目:http://www.mediafire.com/file/ebc8b4hzre7q6r5/Color%20Picker.rar
感谢所有帮助过的人,我非常感谢!我将继续为每个偶然发现这篇文章并发现它有用的人开源项目。没有许可证,无论你想做什么都可以。没有必要的信用,但如果你想留下我的名字,那就太酷了:D
答案 3 :(得分:1)
对DesktopColor
如果创建或GetDC失败,则不会锁定任何资源,解锁或免费将生成错误,因为您正在尝试释放不存在的资源。
规则是初始化应始终在try
之前完成,否则您将不知道解构该条目是否安全。
在这种情况下,这不是一个大问题,因为GetxDC / ReleaseDC不会产生异常,如果不成功则只返回0。
其次,我建议进行测试以确保使用DC的呼叫成功。使用Delphi对象时,您不需要它,因为异常会处理这些,但Windows DC不使用异常,因此您必须自己进行测试。我建议使用断言,因为您可以在调试时启用它,并在调试程序时禁用它们。
但是因为GetxDC从不生成异常并且保持一致,所以我建议将代码更改为:
{$C+} //enable assertions for debug purposes.
//or {$C-} //Disable assertions in production code
function DesktopColor(const X, Y: Integer): TColor;
var
Color: TCanvas;
Handle: THandle;
begin
Color := TCanvas.Create;
//If the create fails GetWindowsDC will not get stored anywhere
//and we cannot free it.
Handle:= GetWindowDC(GetDesktopWindow);
try
Assert(Handle <> 0);
Color.Handle := Handle; //Will generate an exception if create failed.
Handle := 0;
Result := GetPixel(Color.Handle, X, Y);
finally
//Free the handle if it wasn't transfered to the canvas.
if Handle <> 0 then ReleaseDC(0, Handle);
Color.Free; //TCanvas.Destroy will call releaseDC on Color.handle.
//If the transfer was succesful
end; {tryf}
end;
相同的论点适用于Timer1Timer
。
警告强>
当您禁用断言时,Delphi将从您的项目中删除整个assert
语句,因此不要将任何带副作用的代码放入断言中!
<强>链接:强>
断言:http://beensoft.blogspot.com/2008/02/using-assert.html