Freebie Friday: capture controls or forms

New year, new ideas. So, I’m happy to kick off with one of the many new ideas we have, which is the Freebie Friday!

Freebie Friday is simple. We share a useful code snippet that might be handy in your projects. We present it, you copy and paste it and you use it in your applications where you see use for it. Freebie Friday free source code snippets are the result of our daily work, writing components, offering support & consulting for customers … Over time, a huge collection of useful code builds up and instead of letting this collect dust, we cheer up your Friday, just before the weekend and present it here.

This first freebie is two routines that enable you to capture a control as image. The first that might come up is, why write a routine for this, a control offers control.PaintTo() and we can just use that to have the control paint to a canvas and save that to a file.

In theory yes, in practice, sadly this doesn’t work well with many controls. So, therefore these two routines that do work with any VCL control and as a bonus, it works with a VCL form as well, so you can capture entire forms to a bitmap or image.

Here we go, here is the code:

interface

uses
  Classes, Windows, Messages, Graphics, JPEG, Controls, Types, Forms;

procedure CaptureControl(AControl: TControl; ABitmap: TBitmap);
procedure CaptureControlToJpeg(AControl: TControl; AFileName: string; AQuality: integer = 70);

implementation

uses
  Winapi.DwmApi, SysUtils;

procedure CaptureControl(AControl: TControl; ABitmap: TBitmap);
var
  LDesktopDC: HDC;
  LRect: TRect;
  LDWMRect: TRect;
  LPt: TPoint;
begin
  LPt := AControl.ClientToScreen(Point(0,0));

  LRect := Rect(LPt.X, LPt.Y, LPt.X + AControl.Width, LPt.Y + AControl.Height);

  if (AControl is TWinControl) and (AControl as TWinControl).HandleAllocated then
  begin
    GetWindowRect((AControl as TWinControl).Handle, LRect);
  end;

  if (AControl is TCustomForm) and (AControl as TCustomForm).HandleAllocated then
  begin
    GetWindowRect((AControl as TCustomForm).Handle, LRect);

    if (Win32MajorVersion >= 6) and DwmCompositionEnabled then
    begin
      if (DwmGetWindowAttribute((AControl as TCustomForm).Handle, DWMWA_EXTENDED_FRAME_BOUNDS, @LDWMRect, SizeOf(LDWMRect)) = S_OK) then
      begin
        LRect := LDWMRect;
      end;
    end;
  end;

  LDesktopDC := GetWindowDC(GetDesktopWindow);
  try
    ABitmap.PixelFormat := pf24bit;
    ABitmap.Height := LRect.Bottom - LRect.Top;
    ABitmap.Width := LRect.Right - LRect.Left;

    BitBlt(ABitmap.Canvas.Handle, 0, 0, ABitmap.Width, ABitmap.Height, LDesktopDC, LRect.Left, LRect.Top, SRCCOPY);
  finally
    ReleaseDC(GetDesktopWindow, LDesktopDC);
  end;
end;

procedure CaptureControlToJpeg(AControl: TControl; AFileName: string; AQuality: integer = 70);
var
  LJpeg: TJpegImage;
  LBmp: TBitmap;
begin
  LBmp := TBitmap.Create;
  try
    CaptureControl(AControl, LBmp);
    LJpeg := TJpegImage.Create;
    try
      LJpeg.Assign(LBmp);
      LJpeg.CompressionQuality := AQuality;
      LJpeg.SaveToFile(AFileName);
    finally
      LJpeg.Free;
    end;
  finally
    LBmp.Free;
  end;
end;

To use these routines, you can do this with:

begin
  // capture a control to JPEG file setting JPEG quality to 90
  CaptureControlToJpeg(mycontrol, 'mycontrol.jpg', 90);
  // capture a form (Self) to JPEG file setting JPEG quality to 50
  CaptureControlToJpeg(Self, 'myform.jpg', 50);
end;

To capture a control to bitmap, use:

var
  LBmp: TBitmap;
begin
  LBmp := TBitmap.Create;
  try
      CaptureControl(mycontrol, LBmp); 
      // do what you want with the bitmap here 
  finally
    LBmp.Free;
  end;
end;

Enjoy and have a good weekend!