Screenshot a Component

[Delphied 0]

Are there any companies that enable the ability to screenshot a specific component on a form?  I found https://greatis.com/delphicb/screenshot/, but I don't believe they are in business anymore.  Something like this would be most helpful and thanks in advance!

[FPiette 390]

I have this code:

procedure TScreenDumpForm.ScreenDump(
    const FileName : String);
var
    Stream : TFileStream;
    c      : TCanvas;
    r1     : TRect;
    r2     : TRect;
    b      : TBitmap;
    j      : TJPEGImage;
begin
    c      := TCanvas.Create;
    b      := TBitmap.Create;
    j      := TJPEGImage.Create;
    Stream := TFileStream.Create(FileName, fmCreate);
    try
        c.Handle := GetWindowDC(GetDesktopWindow);
        try
            r1            := Screen.MonitorFromWindow(Handle).BoundsRect;
            r2.Top        := 0;
            r2.Left       := 0;
            r2.Width      := r1.Width;
            r2.Height     := r1.Height;
            b.Width       := r1.Width;
            b.Height      := r1.Height;
            b.PixelFormat := pf24bit;
            b.Canvas.CopyRect(r2, c, r1);
            j.CompressionQuality := 60;
            j.Assign(b);
            j.SaveToStream(Stream);
        finally
            ReleaseDC(0, c.Handle);
            c.Free;
            b.Free;
            j.Free;
        end;
    finally
        Stream.Free;
    end;
end;

 

[bravesofts 24]

unit Main.View;

interface

uses
{$REGION '  Defaults Units .. '}
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.ExtCtrls,
  Vcl.Buttons,
  Vcl.StdCtrls,
{$ENDREGION}
//
  System.Types;

type
  TMainView = class(TForm)
    Lbl1: TLabel;
    Btn1: TButton;
    Pnl1: TPanel;
    Pnl2: TPanel;
    Btn2: TButton;
    Lbl2: TLabel;
    Btn3: TSpeedButton;
    BtnCapture: TButton;
    ImgCapturedCtrl: TImage;
    CmboBox_Ctrls: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure BtnCaptureClick(Sender: TObject);
  private
    function CaptureControl(aControl: TControl): TBitmap; inline;
  public
    { Public declarations }
  end;

var
  MainView: TMainView;

implementation

{$R *.dfm}

function TMainView.CaptureControl(aControl: TControl): TBitmap;
var
  LDC: HDC;
  LRect: TRect;
  LCtrlHwnd: THandle;
  LOffset: TPoint;
begin
  Result := TBitmap.Create;
  try
    LRect := aControl.BoundsRect;
    Result.SetSize(LRect.Width, LRect.Height);
    Result.Canvas.Brush.Color := clWhite;
    Result.Canvas.FillRect(Rect(0, 0, LRect.Width, LRect.Height));
    Result.Canvas.Lock;
    try
      if aControl is TWinControl then
      begin
        LCtrlHwnd := TWinControl(aControl).Handle;
        LOffset := Point(0, 0);  // No offset needed for TWinControl
      end
      else
      begin
        LCtrlHwnd := TWinControl(aControl.Parent).Handle;
        LOffset := aControl.BoundsRect.TopLeft;  // Convert to parent-relative coordinates
      end;

      LDC := GetDC(LCtrlHwnd);
      try
        BitBlt(Result.Canvas.Handle, 0, 0, LRect.Width, LRect.Height,
          LDC, LOffset.X, LOffset.Y, SRCCOPY);
      finally
        ReleaseDC(LCtrlHwnd, LDC);
      end;
    finally
      Result.Canvas.Unlock;
    end;
  except
    Result.Free;
    raise;
  end;
end;

procedure TMainView.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  CmboBox_Ctrls.Items.Clear;
  for I := 0 to Self.ComponentCount - 1 do
    if Self.Components[I] is TControl then
      CmboBox_Ctrls.Items.Add(Self.Components[I].Name);


  CmboBox_Ctrls.ItemIndex := 0;

end;

procedure TMainView.BtnCaptureClick(Sender: TObject);
var
  LCtrl: TControl;
  LBmp: TBitmap;
begin
  if CmboBox_Ctrls.ItemIndex <> -1 then
  begin
    LCtrl := FindComponent(CmboBox_Ctrls.Text) as TControl;
    if Assigned(LCtrl) then
    begin
      LBmp := CaptureControl(LCtrl);
      try
        ImgCapturedCtrl.Picture.Assign(LBmp);
      finally
        LBmp.Free;
      end;
    end;
  end;
end;

end.

Dfm

object MainView: TMainView
  Left = 0
  Top = 0
  Margins.Left = 5
  Margins.Top = 5
  Margins.Right = 5
  Margins.Bottom = 5
  Caption = 'MainView'
  ClientHeight = 297
  ClientWidth = 705
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -18
  Font.Name = 'Segoe UI'
  Font.Style = []
  OnCreate = FormCreate
  PixelsPerInch = 144
  TextHeight = 25
  object Lbl1: TLabel
    Left = 417
    Top = 33
    Width = 33
    Height = 25
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
    Caption = 'Lbl1'
  end
  object ImgCapturedCtrl: TImage
    Left = 18
    Top = 117
    Width = 304
    Height = 176
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
  end
  object Btn1: TButton
    Left = 558
    Top = 18
    Width = 125
    Height = 47
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
    Caption = 'Btn1'
    TabOrder = 0
  end
  object Pnl1: TPanel
    Left = 402
    Top = 202
    Width = 281
    Height = 68
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
    Caption = 'Pnl1'
    TabOrder = 1
  end
  object Pnl2: TPanel
    Left = 402
    Top = 90
    Width = 281
    Height = 107
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
    Caption = 'Pnl2'
    TabOrder = 2
    object Lbl2: TLabel
      Left = 174
      Top = 27
      Width = 33
      Height = 25
      Margins.Left = 5
      Margins.Top = 5
      Margins.Right = 5
      Margins.Bottom = 5
      Caption = 'Lbl2'
    end
    object Btn3: TSpeedButton
      Left = 150
      Top = 69
      Width = 118
      Height = 33
      Margins.Left = 5
      Margins.Top = 5
      Margins.Right = 5
      Margins.Bottom = 5
    end
    object Btn2: TButton
      Left = 15
      Top = 27
      Width = 113
      Height = 38
      Margins.Left = 5
      Margins.Top = 5
      Margins.Right = 5
      Margins.Bottom = 5
      Caption = 'Btn2'
      TabOrder = 0
    end
  end
  object BtnCapture: TButton
    Left = 18
    Top = 21
    Width = 304
    Height = 50
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
    Caption = 'Get Control Capture'
    TabOrder = 3
    OnClick = BtnCaptureClick
  end
  object CmboBox_Ctrls: TComboBox
    Left = 18
    Top = 81
    Width = 304
    Height = 33
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
    TabOrder = 4
    Text = 'CmboBox_Ctrls'
  end
end

good luck..

[Der schöne Günther 325]

function TWinControlHelper.CreateBitmap(): TBitmap;
var
	DC: 	HDC;
begin
	DC := GetWindowDC(Handle);
	try
		Result := TBitmap.Create();
		try
			Result.SetSize(Width, Height);
			BitBlt(
				Result.Canvas.Handle,
				0, 0, Result.Width, Result.Height,
				DC, 0, 0,
				WinApi.Windows.SRCCOPY
			);
		except
			Result.Destroy(); raise;
		end;
	finally
		ReleaseDC(Handle, DC);
	end;
end;

I use this...

Limited to TWinControl decendants, though...

Edited 15 hours ago by Der schöne Günther

[PeterBelow 247]

19 hours ago, Delphied said:

Are there any companies that enable the ability to screenshot a specific component on a form?  I found https://greatis.com/delphicb/screenshot/, but I don't believe they are in business anymore.  Something like this would be most helpful and thanks in advance!

If you only need to capture TWincontrol decendants you can do this with a few code lines using the TWincontrol.PaintTo or TWincontrol.PaintWindow methods, using a properly sized TBitmap as target. 

[Delphied 0]

Thanks all!  I will give these a shot and see how it comes out!  Really appreciate the assistance!