// efg, www.efg2.com/Lab
// Feb 2001
//
// Show how to create TBitmap from TLabel, TPanel and TBitBtn controls.
// "Kludge" method for TPageControl and TTabSheet is also shown.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, ComCtrls;

type
  TFormControlBitmap = class(TForm)
    Image1: TImage;
    BitBtn1: TBitBtn;
    ButtonBitBtn: TButton;
    Panel1: TPanel;
    LabelTest: TLabel;
    Shape1: TShape;
    Shape2: TShape;
    ButtonPanel: TButton;
    ButtonLabel: TButton;
    Label1: TLabel;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    Shape3: TShape;
    Shape4: TShape;
    Label2: TLabel;
    Label3: TLabel;
    ButtonPageControl: TButton;
    ButtonTabsheet: TButton;
    procedure ButtonBitBtnClick(Sender: TObject);
    procedure ButtonPanelClick(Sender: TObject);
    procedure ButtonLabelClick(Sender: TObject);
    procedure ButtonPageControlClick(Sender: TObject);
    procedure ButtonTabsheetClick(Sender: TObject);
  private
    FUNCTION ControlToBitmap(CONST Control:  TControl):  TBitmap;
  public
    { Public declarations }
  end;

var
  FormControlBitmap: TFormControlBitmap;

implementation
{$R *.DFM}

  // Based on UseNet Posting on 3 Feb 2001 by Peter Below
  // to borland.public.delphi.objectpascal.  The Control must
  // be visible for this to work.  The calling routine is
  // responsible for freeing the bitmap that is returned.
  FUNCTION TFormControlBitmap.ControlToBitmap(CONST Control:  TControl):  TBitmap;

  BEGIN
    RESULT        := TBitmap.Create;
    RESULT.Width  := Control.Width;
    RESULT.Height := Control.Height;
    RESULT.PixelFormat := pf24bit;    // avoid palettes

    RESULT.Canvas.Lock;
    TRY
      Control.Perform(WM_PAINT, RESULT.Canvas.Handle, 0 );
    FINALLY
      RESULT.Canvas.Unlock
    END
  END {ControlToBitmap};


procedure TFormControlBitmap.ButtonLabelClick(Sender: TObject);
  VAR
    Bitmap: TBitmap;
begin
  Bitmap := ControlToBitmap(Label1);
  TRY
    Image1.Picture.Graphic := Bitmap
  FINALLY
    Bitmap.Free
  END;
end;


procedure TFormControlBitmap.ButtonBitBtnClick(Sender: TObject);
  VAR
    Bitmap: TBitmap;
begin
  Bitmap := ControlToBitmap(BitBtn1);
  TRY
    Image1.Picture.Graphic := Bitmap
  FINALLY
    Bitmap.Free
  END;
end;


procedure TFormControlBitmap.ButtonPanelClick(Sender: TObject);
 VAR
    Bitmap: TBitmap;
begin
  Bitmap := ControlToBitmap(Panel1);
  TRY
    Image1.Picture.Graphic := Bitmap
  FINALLY
    Bitmap.Free
  END;
end;


procedure TFormControlBitmap.ButtonPageControlClick(Sender: TObject);
  VAR
    Bitmap:  TBitmap;
BEGIN
  Bitmap       := TBitmap.Create;
  TRY
    Bitmap.Width  := PageControl1.Width;
    Bitmap.Height := PageControl1.Height;
    Bitmap.PixelFormat := pf24bit;    // avoid palettes

    Bitmap.Canvas.Lock;
    TRY
      // What Windows message paints this area?
      Bitmap.Canvas.Brush.Color := clActiveBorder;
      Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);

      PageControl1.Perform(WM_PAINT, Bitmap.Canvas.Handle, 0 );
      Tabsheet1.Perform(WM_PAINT, Bitmap.Canvas.Handle, 0)
    FINALLY
      Bitmap.Canvas.Unlock
    END;

    Image1.Picture.Graphic := Bitmap;
  FINALLY
    Bitmap.Free
  END
end;

procedure TFormControlBitmap.ButtonTabsheetClick(Sender: TObject);
  VAR
    Bitmap:  TBitmap;
BEGIN
  Bitmap       := TBitmap.Create;
  TRY
    Bitmap.Width  := Tabsheet2.Width;
    Bitmap.Height := Tabsheet2.Height;
    Bitmap.PixelFormat := pf24bit;    // avoid palettes

    Bitmap.Canvas.Lock;
    TRY
      // What Windows message paints this area?
      Bitmap.Canvas.Brush.Color := clActiveBorder;
      Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);

      Tabsheet2.Perform(WM_PAINT, Bitmap.Canvas.Handle, 0)
    FINALLY
      Bitmap.Canvas.Unlock
    END;

    Image1.Picture.Graphic := Bitmap;
  FINALLY
    Bitmap.Free
  END
end;

end.