在全屏表单后面的屏幕截图会导致黑屏 [英] Screenshot behind a full screen Form results in a black screen

问题描述

我要捕获桌面的图像，该图像在捕获时会忽略我的表单。我喜欢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:	ela.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;

推荐答案

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

覆盖窗体是一个无边框窗体(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

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

这篇关于在全屏表单后面的屏幕截图会导致黑屏的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！