Wie mache ich einen screenshot in Z-Order mit PrintWindow-API?

[Rudy Velthuis]

Zitat von flashcoder:

Ich versuche, einen C-Code zu übersetzen, der Screenshots in Z-Reihenfolge aufnehmen kann.

Meine Version. Keine Ahnung ob die macht, was du möchtest. Ich weiß nämlich nicht genau, was du möchtest.

Delphi-Quellcode:

program PrintInZOrder;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  Winapi.Windows,
  Vcl.Graphics;

function PrintWindow(hwnd: HWND; hdcBlt: HDC; nFlags: UInt32): BOOL; stdcall; external 'user32.dll' name 'PrintWindow';

function xPrintWindow(hWnd: HWND; hdc, hdcScreen: HDC): Boolean;
var
  ret: Boolean;
  rect: TRect;
  hdcWindow: Winapi.Windows.HDC;
  hbmpWindow: HBITMAP;
begin
  ret := False;
  GetWindowRect(hWnd, rect);

  hdcWindow := CreateCompatibleDC(hDC);
  hbmpWindow := CreateCompatibleBitmap(hDC, rect.Width, rect.Height);

  SelectObject(hdcWindow, hbmpWindow);
  if PrintWindow(hWnd, hdcWindow, 0) then
  begin
    BitBlt(hdcScreen, rect.Left, rect.Top, rect.Width, rect.Height, hdcWindow, 0, 0, SRCCOPY);
    ret := True;
  end;
  DeleteObject(hbmpWindow);
  DeleteDC(hdcWindow);
  Result := ret;
end;

// https://stackoverflow.com/a/55885143/95954

type
  WNDENUMPROC = function(hwnd: HWND; lParam: LPARAM): BOOL stdcall;

procedure EnumWindowsTopToDown(owner: HWND; proc: WNDENUMPROC; param: LPARAM);
var
  currentWindow: HWND;
begin
  currentWindow := GetTopWindow(owner);
  if currentWindow = 0 then
    Exit;
  currentWindow := GetWindow(currentWindow, GW_HWNDLAST);
  while (currentWindow <> 0) and proc(currentWindow, param) do
    currentWindow := GetWindow(currentWindow, GW_HWNDPREV);
end;

type
  PEnumHwndsPrintData = ^TEnumHwndsPrintData;
  TEnumHwndsPrintData = record
    hdc, hdcScreen: Winapi.Windows.HDC;
  end;

function EnumHwndsPrint(hwnd: HWND; lParam: LPARAM): BOOL; stdcall;
var
  data: PEnumHwndsPrintData;
  style: Integer;
begin
  data := PEnumHwndsPrintData(LPARAM);
  if not IsWindowVisible(hwnd) then
    Exit(True);
  xPrintWindow(hwnd, data^.hdc, data^.hdcScreen);
  // Folgende Zeilen machen die IDE total banane (Endlos-Repaint-Schleife), und sind wohl nicht nötig. Wenn doch, dann nur ohne IDE starten.
 
//  style := GetWindowLongA(hwnd, GWL_EXSTYLE);
//  SetWindowLongA(hwnd, GWL_EXSTYLE, style or WS_EX_COMPOSITED);
  Result := True;
end;

procedure testPrintWindow(serverWidth, serverHeight: Integer);
var
  rect: TRect;
  hwndDesktop: HWND;
  hdc, hdcScreen: Winapi.Windows.HDC;
  hbmpScreen: HBITMAP;
  data: TEnumHwndsPrintData;
  hbmpScreenResized: HBITMAP;
  hdcScreenResized: Winapi.Windows.HDC;
  image: TBitmap;
begin
  hwndDesktop := GetDesktopWindow;
  GetWindowRect(hwndDesktop, rect);

  hdc := GetDC(0);
  hdcScreen := CreateCompatibleDC(hdc);
  hbmpScreen := CreateCompatibleBitmap(hdc, rect.Right, rect.Bottom);
  SelectObject(hdcScreen, hbmpScreen);

  data.hdc := hdc;
  data.hdcScreen := hdcScreen;

  EnumWindowsTopToDown(0, EnumHwndsPrint, Winapi.Windows.LPARAM(@data));

  if serverWidth > rect.Right then
    serverWidth := rect.Right;
  if serverHeight > rect.Bottom then
    serverHeight := rect.Bottom;

  if (serverWidth <> rect.Right) or (serverHeight <> rect.Bottom) then
  begin
    // Diesen Block kann man wahrscheinlich viel einfacher direkt mit einer Vcl.Graphics.TBitmap ausführen.
    hbmpScreenResized := CreateCompatibleBitmap(hdc, serverWidth, serverHeight);
    hdcScreenResized := CreateCompatibleDC(hdc);

    SelectObject(hdcScreenResized, hbmpScreenResized);
    SetStretchBltMode(hdcScreenResized, HALFTONE);
    StretchBlt(hdcScreenResized, 0, 0, serverWidth, serverHeight, hdcScreen, 0, 0, rect.Right, rect.Bottom, SRCCOPY);

    DeleteObject(hbmpScreen);
    DeleteDC(hdcScreen);

    hbmpScreen := hbmpScreenResized;
    hdcScreen := hdcScreenResized;
  end;

  image := TBitmap.Create;
  try
    image.Handle := hbmpScreen;
    image.SaveToFile('output.bmp');
  finally
    image.Free;
  end;

  // Nicht im Original, aber hier notwendig.
  DeleteDC(hdcScreen);

end;

procedure Main;
begin
  testPrintWindow(800, 600);
  Writeln('Gespeichert, bitte Enter-Taste drücken...');
end;

begin
  try
    Main;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.