全屏表格后面的屏幕截图导致黑屏

Question

我想捕捉一张桌面图像，捕捉时忽略我的表格。我喜欢this answer，但一直无法截取桌面内容，只有黑屏。

所以，我需要帮助来解决这个问题。

这是我的版本，稍作改动：

private
    { Private declarations }
    DesktopBMP: TBitmap;
    procedure WMEraseBkgnd( var Message: TWMEraseBkgnd ); message WM_ERASEBKGND;
  public
    { Public declarations }
    protected
    procedure Paint; override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
DesktopBMP := TBitmap.Create;
  DesktopBMP.SetSize( Screen.Width, Screen.Height );
  DoubleBuffered := True;
end;

procedure TForm1.tmr1Timer(Sender: TObject);
begin
  Width := 0;
  Height := 0;
  Width := Screen.Width;
  Height := Screen.Height;
end;

procedure TForm1.Paint;
begin
  inherited;
  //Canvas.Draw( 0, 0, DesktopBMP );
  DesktopBMP.SaveToFile('c:\tela.bmp');
end;

procedure TForm1.WMEraseBkgnd( var Message: TWMEraseBkgnd );
var
  DesktopDC: HDC;
  DesktopHwnd: Hwnd;
  DesktopCanvas: TCanvas;
begin
  DesktopHwnd := GetDesktopWindow;
  DesktopDC := GetDC( DesktopHwnd );
  try
    DesktopCanvas := TCanvas.Create;
    DesktopCanvas.Handle := DesktopDC;
    DesktopBMP.Canvas.CopyRect( Rect( 0, 0, Screen.Width, Screen.Height ), DesktopCanvas, Rect( 0, 0, Screen.Width, Screen.Height ) );
  finally
    DesktopCanvas.Free;
    ReleaseDc( DesktopHwnd, DesktopDC );
  end;
  Message.Result := 1;
  inherited;
end;

Answer 1

这是一个基于您提供的代码的解决方案。

覆盖窗体是无边框的（BorderStyle = bsNone），它有两个按钮，一个用于截取底层屏幕的屏幕截图，一个用于终止应用程序（因为我们在标题中没有按钮).

代码的主要变化是

表单中的两个私有字段

DoSnapShot: boolean; // to control when to copy the screen
ScreenRect: TRect;   // to hold the rectangle of the overlay

和一个程序

procedure TakeScreenShot;

TakeScreenShot 替换了代码中的 OnTimer 处理程序，并在重置 Width 和 Height[ 之前添加设置布尔值 DoSnapShot = True =23=]

WMEraseBkgnd 修改为仅在 DoSnapShot = True.

时尝试复制底层屏幕

完整代码如下

type
  TForm3 = class(TForm)
    ScreenBtn: TButton;
    ExitBtn: TButton;
    procedure FormCreate(Sender: TObject);
    procedure ScreenBtnClick(Sender: TObject);
    procedure ExitBtnClick(Sender: TObject);
  private
    DesktopBMP: TBitmap;
    DoSnapShot: boolean; // to control when to copy the screen
    ScreenRect: TRect;   // to hold the rectangle of the overlay
    procedure TakeScreenShot;
    procedure WMEraseBkgnd( var Message: TWMEraseBkgnd ); message WM_ERASEBKGND;
  protected
    procedure Paint; override;
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

procedure TForm3.ScreenBtnClick(Sender: TObject);
begin
  TakeScreenShot;
end;

procedure TForm3.ExitBtnClick(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
  Left := 0;
  Top := 0;
  Width := Screen.Width;
  Height := Screen.Height-10;

  ScreenRect := Rect(Left, Top, Width, Height);

  DesktopBMP := TBitmap.Create;
  DesktopBMP.SetSize( Width, Height );
end;

procedure TForm3.Paint;
begin
  inherited;
  Canvas.Draw( 0, 0, DesktopBMP );
end;

procedure TForm3.TakeScreenShot;
begin
  Width := 0;   // will not trigger copying
  Height := 0;  //
  DoSnapShot := True;  // now enable copying the underlying screen
  Width := ScreenRect.Width;    //
  Height := ScreenRect.Height;  // and trigger it in WMEraseBkgnd
end;

procedure TForm3.WMEraseBkgnd(var Message: TWMEraseBkgnd);
var
  DesktopDC: HDC;
  DesktopHwnd: Hwnd;
  DesktopCanvas: TCanvas;
begin
  if DoSnapShot then
  begin
    DoSnapShot := False; // Disable repeated copying
    DesktopHwnd := GetDesktopWindow;
    DesktopDC := GetDC( DesktopHwnd );
    try
      DesktopCanvas := TCanvas.Create;
      DesktopCanvas.Handle := DesktopDC;
      DesktopBMP.Canvas.CopyRect( ScreenRect , DesktopCanvas, ScreenRect );
    finally
      DesktopCanvas.Free;
      ReleaseDc( DesktopHwnd, DesktopDC );
    end;
  end;
  Message.Result := 1;
  inherited;
end;

end.

和 .dfm:

object Form3: TForm3
  Left = 0
  Top = 0
  BorderStyle = bsNone
  Caption = 'Form3'
  ClientHeight = 139
  ClientWidth = 225
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object ScreenBtn: TButton
    Left = 8
    Top = 8
    Width = 75
    Height = 25
    Caption = 'ScreenShot'
    TabOrder = 0
    OnClick = ScreenBtnClick
  end
  object ExitBtn: TButton
    Left = 8
    Top = 40
    Width = 75
    Height = 25
    Caption = 'Exit'
    TabOrder = 1
    OnClick = ExitBtnClick
  end
end

全屏表格后面的屏幕截图导致黑屏

Screenshot behind a full screen Form results in a black screen

delphi

vcl

screenshot

fullscreen