全屏幕背后的屏幕截图导致黑屏

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

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

重叠表单是一个无边框表单（DoSnapShot: boolean; // to control when to copy the screen ScreenRect: TRect; // to hold the rectangle of the overlay ），它有两个按钮，一个用于截取底层屏幕的截图，另一个用于终止应用程序（因为我们在标题中没有按钮）。

您的代码的主要更改是

表单中的两个私有字段

procedure TakeScreenShot;

和程序

TakeScreenShot

OnTimer替换代码中的DoSnapShot = True处理程序，并在重置Width和Height之前添加设置布尔值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 ：

{{1}}