My Delphi Program Seems to be Leaking

Question

Ok, so I'm pretty new to Delphi (as you'll see from my code - try not to laugh too hard and hurt yourselves), but I've managed to make a little desktop canvas color picker. It works, kinda, and that's why I'm here :D

It seems to be leaking. It starts off using about 2 MB of memory, and climbs up about 2 kB per second until it reaches about 10 MB after 10 minutes or so. On my dual core 2.7 ghz cpu, it's using anywhere from 5% to 20% cpu power, fluctuating. My computer became unresponsive after running it for about 10 minutes without stopping the timer.

You can see in the source code below that I am freeing the TBitmap (or trying to, not sure if it's doing it, doesn't seem to be working).

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;

Note: The timer is set to run every 10 ms, if that makes any difference.

ANY and all help figuring out why this is leaking and using so much resources would be greatly appreciated!

You can nab the project here if you want it (Delphi 2010): http://www.mediafire.com/file/cgltcy9c2s80f74/Color%20Picker.rar

Thanks!

Answer 1

Ok, I found the solution (finally) after tinkering around with it a bit and following a few of the pointers on here. No one really hit it right on the head, but everyone was on the right track. The problem was that I was calling GetDC() inside the FUNCTION (and in earlier versions the timer procedure as well). Moving it outside of "try ... finally" while keeping it in the function (as suggested) still didn't yield results, but it was getting close and gave me the idea that actually worked. So I moved it a bit further away - into the Form's OnCreate event.

Here's the final code:

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;

And the final tally: drumroll CPU usage: 00% idle, 01% spikes if you move the mouse fast enough; Memory usage: ~3,500 kB solid, remaining unchanged. I even bumped the timer up from 10 ms to 5 ms and still get the same numbers.

Here's the final project with all the aforementioned fixes: http://www.mediafire.com/file/ebc8b4hzre7q6r5/Color%20Picker.rar

Thanks to everyone who helped, I greatly do appreciate it! I'm going to go ahead and open source the project for everyone who stumbles across this post and finds it useful. No license, do with it whatever you will. No credit necessary, but if you want to leave my name in there, that would be cool :D

Answer 2

Some comments on your code in DesktopColor

If the creation or GetDC fails, no resource will be locked and the unlock or free will generate an error, because you are trying to free a resource that does not exist.

The rule is that initialization should always be done before the try, because otherwise you will not know whether is is safe to deconstruct the entry.
In this case it's not a huge issue because GetxDC/ReleaseDC does not generate exceptions, it just gives back a 0 if unsuccesful.

Secondly I recommend putting in tests to make sure that your calls using DC's are succesful. When using Delphi objects you don't need that because the exceptions will take care of that, but Windows DC do not use exceptions, so you'll have to do your own testing. I recommend using assertions, because you can enable then in debug time and disable them when the program is debugged.

But because GetxDC never generates exceptions and to be consistent I'd recommend changing the code into:

{$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;

The same arguments apply to Timer1Timer.

Warning
When you disable assertions Delphi will remove the entire assert statement from your project, so don't put any code with side effects into an assert!

Links:
Assertions: http://beensoft.blogspot.com/2008/02/using-assert.html

Answer 3

As user said above, TCanvas instance which owns DC of desktop window never freed, not releasing DC. I found another DC leak here:

BitBlt(Pxl2.Canvas.Handle, 0, 0, 1, 1, GetDC(0), Box1, Box2, SRCCOPY);
                                       ^^^^^^^^

This not solves memory leak but explains why Windows becomes unresponsive after 20 minutes (assuming previous issue has been patched already)

---

Every GetDC call requires ReleaseDC counter-part. GDI objects in the fact are even more precious than memory.

Answer 4

You never free your Canvas1 object, leaking both process heap and GDI obj. handles.