Hallo,

wir haben unten stehend Funktion zum generieren eines Screenshots von einem aktiven beliebigem Programm.
Dazu haben wir in einem Hintergrundprogramm mit RegisterHotKey(fmain.Handle, ID3, MOD_ALT, vk_f10); uns die Screenshot Funktion auf eine Tastenkombi gelegt und können somit ein Bitmap vom aktiven Fenster durchführen und dann als Bild speichern, drucken oder in die Zwischenablage kopieren.

Folgendes passiert mit dem Titel z.b reproduzierbar mit Notepad, Word, Excel usw.

1.Notepad öffnen
2.Inhalt = Test
3.Datei speichern als test.txt. Damit steht in der Titelteile "test.txt - Editor"
4.Inhalt ändern auf Test2
5.Datei speichern als test2.txt. Damit steht in der Titelteile "test2.txt - Editor"
6.Nun den Screenshot erstellen und abspeichern oder per Zwischenablage in Paint einfügen

Nun steht in dem Screenshot in der Titelzeile "test.txt - Editor"
Unter der Titelzeile also im Textbereich wird aber das korrekte im Screenshot angezeigt.

Wird zwischen Punkt 5 und 6 der Editor minimiert und wieder angezeigt passiert folgendes
- Korrekter Titel ist im Screenshot
- Titelzeile fehlt komplett im Screenshot

Im Anhang der Quellcode und das Programm.
Frage wäre wo der Fehler ist oder es eine bessere Lösung zum erstellen des Screenshot gibt.

markieren

Code:

const ID3 = $FD;

procedure ScreenShot(activeWindow: bool; destBitmap : TBitmap) ;
 var
    w,h : integer;
    DC  : HDC;
    hWin : Cardinal;
    r  : TRect;
    ProcessID : THandle;
 begin

    if activeWindow then begin
      hWin := GetForegroundWindow;
      dc := GetWindowDC(hWin) ;
      GetWindowRect(hWin,r) ;
      w := r.Right - r.Left;
      h := r.Bottom - r.Top;
    end else begin
      hWin := GetDesktopWindow;
      dc := GetDC(hWin) ;
      w := GetDeviceCaps (DC, HORZRES) ;
      h := GetDeviceCaps (DC, VERTRES) ;
    end;

    try
     destBitmap.Width := w;
     destBitmap.Height := h;
     BitBlt(destBitmap.Canvas.Handle,
            0,
            0,
            destBitmap.Width,
            destBitmap.Height,
            DC,
            0,
            0,
            SRCCOPY) ;
    finally
     ReleaseDC(hWin, DC) ;
    end;
end;

procedure Tfmain.WMHotKey(Var Msg: TMessage);
var mybitmap: TBitmap;
    d      : TDVorschau;
    clipboard:Tclipboard;
begin
    case Msg. WParam of
        id3:begin
            mybitmap := TBitmap.Create;
            Screenshot(true,mybitmap);
            clipBoard := TClipBoard.Create;
            Clipboard.Assign(mybitmap);
            ClipBoard.free;
            mybitmap.free;
        end;
end;

Erstmal, du machst nicht wirklich ein Foto, von dem, was du "jetzt" siehst,
sondern du sagst diesem Fenster, dass es sich auf auf dein Canvas "neu" draufmalen soll.

Scheinbar tut der Editor aber nur beim Ersten mal den Rahmen zeichnen.
Und danach nur noch den Fensterinhalt.

Du brauchst auch nicht zu speichern
* Editor öffnen
* Alt+F10 -> voller Screenshot
* Text eingeben
* Alt+F10 -> Titelleiste bleibt unverändert .... es müsste ja das Geändert-* auftauchen
* minimieren und zurück
* Alt+F10 -> wieder nur Inhalt, aber Rahmen fehlt


Eventuell bleibt nach dem Malen ein Clipping auf den Content zurück (ClipRect/Region)
und beim nächsten Malen wird dadurch der äußere Bereich vom Zeichnen ausgelassen/abgeschnitten.

Dein Bitmap/Canvas/DC löschen und neu erstellen, machst du ja bereits, also kann sowas nur noch im anderen Programm drin sein, wo du diesbezüglich kaum was machen kannst.

Schau doch mal, ob z.B. GetClipBox oder GetClipRgn etwas liefern.
https://learn.microsoft.com/de-de/wi...32/gdi/regions



Alternativ könntest es noch mit WM_PRINT bzw. WM_PRINTCLIENT versuchen.

Oder eben über die Desktop Duplication API.

So funktionierts bei mir immer, es muss noch ein wenig Hand angelegt werden den Border richtig zu berechnen.

zusammenfalten · markieren

Delphi-Quellcode:

procedure ScreenShot(const ActiveWindow: Boolean; var DestBitmap: TBitmap);
var
  w, h: Integer;
  hWin: Cardinal;
  r: TRect;
  oDC: HDC;
  oCanvas: TCanvas;
  oBitmap: TBitmap;
begin
  if activeWindow then
    hWin := GetForegroundWindow
    else
    hWin := GetDesktopWindow;
  try
    GetWindowRect(hWin, r);
    w := r.Right - r.Left;
    h := r.Bottom - r.Top;
    oCanvas := TCanvas.Create;
    try
      oDC := GetDC(0);
      try
        oBitmap := TBitmap.Create;
        try
          oBitmap.PixelFormat := TPixelFormat.pfDevice;
          oBitmap.Width := w;
          oBitmap.Height := h;
          oCanvas.Handle := oDC;
          oBitmap.Canvas.CopyMode := cmSrcCopy;
          oBitmap.Canvas.CopyRect(
            Rect(0, 0, oBitmap.Width, oBitmap.Height),
            oCanvas,
            Rect(r.Left, r.Top, r.Right, r.Bottom));
        finally
          DestBitmap.Assign(oBitmap);
          oBitmap.Free;
        end;
      finally
        ReleaseDC(0, oDC);
      end;
    finally
      oCanvas.Free;
    end;
  finally
  end;
end;

Nun hat das Bild die korrekte Größe, ohne den "Freiraum"

zusammenfalten · markieren

Delphi-Quellcode:

procedure ScreenShot(const AActiveWindow: Boolean; var ADestBitmap: TBitmap);
var
  w, h: Integer;
  hWin: HWND;
  r: TRect;
  oDC: HDC;
  oCanvas: TCanvas;
  oBitmap: TBitmap;
  BorderHeight,
  BorderWidth: Integer;
begin
  if AActiveWindow then
    hWin := GetForegroundWindow
    else
    hWin := GetDesktopWindow;
  try
    GetWindowRect(hWin, r);
    if AActiveWindow then
      begin
        BorderHeight := GetSystemMetrics(SM_CXDLGFRAME) + GetSystemMetrics(SM_CXSIZEFRAME) + GetSystemMetrics(SM_CXEDGE);
        BorderWidth := GetSystemMetrics(SM_CYDLGFRAME) + GetSystemMetrics(SM_CYSIZEFRAME) + GetSystemMetrics(SM_CYEDGE);
        r.Right := r.Right - BorderWidth;
        r.Left := r.Left + BorderWidth;
        r.Bottom := r.Bottom - BorderHeight;
      end;
    w := r.Right - r.Left;
    h := r.Bottom - r.Top;
    oCanvas := TCanvas.Create;
    try
      oDC := GetDC(0);
      try
        oBitmap := TBitmap.Create;
        try
          oBitmap.PixelFormat := TPixelFormat.pfDevice;
          oBitmap.Width := w;
          oBitmap.Height := h;
          oCanvas.Handle := oDC;
          oBitmap.Canvas.CopyMode := cmSrcCopy;
          oBitmap.Canvas.CopyRect(
            Rect(0, 0, oBitmap.Width, oBitmap.Height),
            oCanvas,
            Rect(r.Left, r.Top, r.Right, r.Bottom));
        finally
          ADestBitmap.Assign(oBitmap);
          oBitmap.Free;
        end;
      finally
        ReleaseDC(0, oDC);
      end;
    finally
      oCanvas.Free;
    end;
  finally
  end;
end;

Ich hoffe es hilft, viel Spaß damit!

Ich habe es nochmal erweitert, nun hast du auch noch einen string mit dem Caption-Namen des Fensters.
(und vorbereitet ge-cross-platformed zu werden)

zusammenfalten · markieren

Delphi-Quellcode:

procedure ScreenShot(var ADestBitmap: TBitmap; var AWindowTitle: string; const AActiveWindow: Boolean = True; const ARemoveBorder: Boolean = True);
  function GetWindowTitle({$IFDEF MSWINDOWS}const AHWND: HWND{$ENDIF}): string;
  var
    LTitle: string;
    LLen: Integer;
  begin
    Result := '';
    {$IFDEF MSWINDOWS}LLen := GetWindowTextLength(AHWND) + 1;{$ENDIF}
    SetLength(LTitle, LLen);
    {$IFDEF MSWINDOWS}GetWindowText(AHWND, PChar(LTitle), LLen);{$ENDIF}
    Result := Trim(LTitle);
  end;
var
  {$IFDEF MSWINDOWS}ShotWindow: HWND;{$ENDIF}
  {$IFDEF MSWINDOWS}ShotRect: TRect;{$ENDIF}
  {$IFDEF MSWINDOWS}ShotDC: HDC;{$ENDIF}
  ShotCanvas: TCanvas;
  ShotBitmap: TBitmap;
  ImageHeight,
  ImageWidth,
  BorderHeight,
  BorderWidth: Integer;
begin
  if AActiveWindow then
    // get handle of the focused window
    {$IFDEF MSWINDOWS}ShotWindow := GetForegroundWindow{$ENDIF}
    else
    // get handle of the desktop
    {$IFDEF MSWINDOWS}ShotWindow := GetDesktopWindow{$ENDIF};
  try
    AWindowTitle := GetWindowTitle(ShotWindow);
    // get size of handle
    {$IFDEF MSWINDOWS}GetWindowRect(ShotWindow, ShotRect){$ENDIF};
    // remove "invisible" area around a window frame
    if (AActiveWindow and ARemoveBorder) then
      begin
        {$IFDEF MSWINDOWS}
        BorderHeight := GetSystemMetrics(SM_CXDLGFRAME) + GetSystemMetrics(SM_CXSIZEFRAME) + GetSystemMetrics(SM_CXEDGE);
        BorderWidth := GetSystemMetrics(SM_CYDLGFRAME) + GetSystemMetrics(SM_CYSIZEFRAME) + GetSystemMetrics(SM_CYEDGE);
        ShotRect.Right := ShotRect.Right - BorderWidth;
        ShotRect.Left := ShotRect.Left + BorderWidth;
        ShotRect.Bottom := ShotRect.Bottom - BorderHeight;
        {$ENDIF}
      end;
    // calculate image size
    {$IFDEF MSWINDOWS}
    ImageWidth := ShotRect.Right - ShotRect.Left;
    ImageHeight := ShotRect.Bottom - ShotRect.Top;
    {$ENDIF}
    // open a canvas
    ShotCanvas := TCanvas.Create;
    try
      // get handle to device context
      {$IFDEF MSWINDOWS}ShotDC := GetDCEx(0, 0, DCX_WINDOW or DCX_PARENTCLIP or DCX_CLIPSIBLINGS or DCX_CLIPCHILDREN){GetDC(0)};{$ENDIF} // (0) = what you see is what you get :-)
      try
        ShotBitmap := TBitmap.Create;
        try
          ShotBitmap.PixelFormat := TPixelFormat.pfDevice;
          ShotBitmap.Width := ImageWidth;
          ShotBitmap.Height := ImageHeight;
          // connect canvas to device context
          {$IFDEF MSWINDOWS}ShotCanvas.Handle := ShotDC;{$ENDIF}
          ShotBitmap.Canvas.CopyMode := cmSrcCopy;
          // copy to image whatever content is in that moment on the screen at given location
          ShotBitmap.Canvas.CopyRect(
            Rect(0, 0, ImageWidth, ImageHeight), // dimension of target
            {$IFDEF MSWINDOWS}ShotCanvas{$ENDIF}, // source to use
            Rect({$IFDEF MSWINDOWS}ShotRect.Left{$ENDIF},
                 {$IFDEF MSWINDOWS}ShotRect.Top{$ENDIF},
                 {$IFDEF MSWINDOWS}ShotRect.Right{$ENDIF},
                 {$IFDEF MSWINDOWS}ShotRect.Bottom{$ENDIF})); // location of source
        finally
          ADestBitmap.Assign(ShotBitmap);
          ShotBitmap.Free;
        end;
      finally
        {$IFDEF MSWINDOWS}ReleaseDC(0, ShotDC){$ENDIF};
      end;
    finally
      ShotCanvas.Free;
    end;
  finally
  end;
end;

procedure Tfmain.WMHotKey(Var Msg: TMessage);
var
  MyBitmap: TBitmap;
  MyClipboard: TClipboard;
  MyTitle: string;
begin
    case Msg. WParam of
        id3: begin
               MyBitmap := TBitmap.Create;
               Screenshot(MyBitmap, MyTitle);
               Image1.Picture.Bitmap.Assign(MyBitmap);
               MyClipboard := TClipBoard.Create;
               MyClipboard.Assign(MyBitmap);
               MyClipBoard.Free;
               MyBitmap.Free;
               lbStatus.Caption := 'Bild in Zwischenablage kopiert : ' + FormatDateTime('hh:nn:ss', Now) + ' (' + MyTitle + ')';
             end;
    end;
end;

Viel Spaß damit!

Hallo zusammen,

danke für die Antworten, ich schaue mir das nachher einmal an.

Wenn das nicht für Windows kompiliert wird, dann meckert wirklich nicht der Compiler?

Kann man kaum glauben. Allein schon beim Anblick des GetWindowTitle.

Nun gibt es auch noch den Prozessnamen in der Ausgabe.

zusammenfalten · markieren

Delphi-Quellcode:

{$IFDEF MSWINDOWS}function GetProcessImageFileName(hProcess: THandle; lpImageFileName: LPTSTR; nSize: DWORD): DWORD; stdcall; external 'PSAPI.dll' name 'GetProcessImageFileNameW';{$ENDIF}
procedure ScreenShot(var ADestBitmap: TBitmap; var AWindowTitle, AProcessName: string; const AActiveWindow: Boolean = True; const ARemoveBorder: Boolean = False);
  function GetWindowPath({$IFDEF MSWINDOWS}const AHWND: HWND{$ENDIF}): string;
    function GetPIDbyHWND({$IFDEF MSWINDOWS}const AHWND: HWND{$ENDIF}): DWORD;
    var
      PID: DWORD;
    begin
      if (AHWND <> 0) then
        begin
          {$IFDEF MSWINDOWS}GetWindowThreadProcessID(AHWND, @PID);{$ENDIF}
          Result := PID;
        end
        else
          Result := 0;
    end;
    {$IFDEF MSWINDOWS}function PhysicalToVirtualPath(APath: string): string;
    var
      i : integer;
      ADrive : string;
      ABuffer : array[0..MAX_PATH - 1] of Char;
      ACandidate : string;
    begin
      {$I-}
      for I := 0 to 25 do
        begin
          ADrive := Format('%s:', [Chr(Ord('A') + i)]);
          if (QueryDosDevice(PWideChar(ADrive), ABuffer, MAX_PATH) = 0) then
            Continue;
          ACandidate := string(ABuffer).ToLower();
          if (string(Copy(APath, 1, Length(ACandidate))).ToLower() = ACandidate) then
            begin
              Delete(APath, 1, Length(ACandidate));
              Result := Format('%s%s', [ADrive, APath]);
            end;
        end;
      {$I+}
    end;{$ENDIF}
  var
    {$IFDEF MSWINDOWS}AHandle: THandle;{$ENDIF}
    ALength : Cardinal;
    AImagePath : String;
  const
    PROCESS_QUERY_LIMITED_INFORMATION = $00001000;
  begin
    Result := '';
    {$IFDEF MSWINDOWS}AHandle := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, GetPIDbyHWND(AHWND));{$ENDIF}
    if (AHandle = 0) then
      Exit;
    try
      SetLength(AImagePath, MAX_PATH);
      {$IFDEF MSWINDOWS}ALength := GetProcessImageFileName(AHandle, @AImagePath[1], MAX_PATH);{$ENDIF}
      if (ALength > 0) then
        begin
          SetLength(AImagePath, ALength);
          Result := {$IFDEF MSWINDOWS}PhysicalToVirtualPath(AImagePath){$ENDIF};
        end;
    finally
      {$IFDEF MSWINDOWS}CloseHandle(AHandle);{$ENDIF}
    end;
  end;
  function GetWindowTitle({$IFDEF MSWINDOWS}const AHWND: HWND{$ENDIF}): string;
  var
    LTitle: string;
    LLen: Integer;
  begin
    Result := '';
    LLen := {$IFDEF MSWINDOWS}GetWindowTextLength(AHWND){$ENDIF} + 1;
    SetLength(LTitle, LLen);
    {$IFDEF MSWINDOWS}GetWindowText(AHWND, PChar(LTitle), LLen);{$ENDIF}
    Result := Trim(LTitle);
  end;
var
  {$IFDEF MSWINDOWS}ShotWindow: HWND;{$ENDIF}
  {$IFDEF MSWINDOWS}ShotRect: TRect;{$ENDIF}
  {$IFDEF MSWINDOWS}ShotDC: HDC;{$ENDIF}
  ShotCanvas: TCanvas;
  ShotBitmap: TBitmap;
  ImageHeight,
  ImageWidth,
  BorderHeight,
  BorderWidth: Integer;
begin
  if AActiveWindow then
    // get handle of the focused window
    {$IFDEF MSWINDOWS}ShotWindow := GetForegroundWindow{$ENDIF}
    else
    // get handle of the desktop
    {$IFDEF MSWINDOWS}ShotWindow := GetDesktopWindow{$ENDIF};
  try
    AWindowTitle := GetWindowTitle(ShotWindow);
    AProcessName := GetWindowPath(ShotWindow);
    // get size of handle
    {$IFDEF MSWINDOWS}GetWindowRect(ShotWindow, ShotRect){$ENDIF};
    // remove "invisible" area around a window frame
    if (AActiveWindow and ARemoveBorder) then
      begin
        {$IFDEF MSWINDOWS}
        BorderHeight := GetSystemMetrics(SM_CXDLGFRAME) + GetSystemMetrics(SM_CXSIZEFRAME) + GetSystemMetrics(SM_CXEDGE);
        BorderWidth := GetSystemMetrics(SM_CYDLGFRAME) + GetSystemMetrics(SM_CYSIZEFRAME) + GetSystemMetrics(SM_CYEDGE);
        ShotRect.Right := ShotRect.Right - BorderWidth;
        ShotRect.Left := ShotRect.Left + BorderWidth;
        ShotRect.Top := ShotRect.Top + BorderHeight;
        ShotRect.Bottom := ShotRect.Bottom - BorderHeight;
        {$ENDIF}
      end;
    // calculate image size
    {$IFDEF MSWINDOWS}
    ImageWidth := ShotRect.Right - ShotRect.Left;
    ImageHeight := ShotRect.Bottom - ShotRect.Top;
    {$ENDIF}
    // open a canvas
    ShotCanvas := TCanvas.Create;
    try
      // get handle to device context
      {$IFDEF MSWINDOWS}ShotDC := GetDCEx(0, 0, DCX_WINDOW or DCX_PARENTCLIP or DCX_CLIPSIBLINGS or DCX_CLIPCHILDREN){GetDC(0)};{$ENDIF} // (0) = what you see is what you get :-)
      try
        ShotBitmap := TBitmap.Create;
        try
          ShotBitmap.PixelFormat := TPixelFormat.pfDevice;
          ShotBitmap.Width := ImageWidth;
          ShotBitmap.Height := ImageHeight;
          // connect canvas to device context
          {$IFDEF MSWINDOWS}ShotCanvas.Handle := ShotDC;{$ENDIF}
          ShotBitmap.Canvas.CopyMode := cmSrcCopy;
          // copy to image whatever content is in that moment on the screen at given location
          ShotBitmap.Canvas.CopyRect(
            Rect(0, 0, ImageWidth, ImageHeight), // dimension of target
            {$IFDEF MSWINDOWS}ShotCanvas{$ENDIF}, // source to use
            Rect({$IFDEF MSWINDOWS}ShotRect.Left{$ENDIF},
                 {$IFDEF MSWINDOWS}ShotRect.Top{$ENDIF},
                 {$IFDEF MSWINDOWS}ShotRect.Right{$ENDIF},
                 {$IFDEF MSWINDOWS}ShotRect.Bottom{$ENDIF})); // location of source
        finally
          ADestBitmap.Assign(ShotBitmap);
          ShotBitmap.Free;
        end;
      finally
        {$IFDEF MSWINDOWS}ReleaseDC(0, ShotDC){$ENDIF};
      end;
    finally
      ShotCanvas.Free;
    end;
  finally
  end;
end;

procedure Tfmain.WMHotKey(Var Msg: TMessage);
var
  MyBitmap: TBitmap;
  MyClipboard: TClipboard;
  MyTitle, MyProcess: string;
begin
    case Msg. WParam of
        id3: begin
               MyBitmap := TBitmap.Create;
               Screenshot(MyBitmap, MyTitle, MyProcess, True, CheckBox1.Checked);
               Image1.Picture.Bitmap.Assign(MyBitmap);
               MyClipboard := TClipBoard.Create;
               MyClipboard.Assign(MyBitmap);
               MyClipBoard.Free;
               MyBitmap.Free;
               lbStatus.Caption := 'Bild in Zwischenablage kopiert : ' + FormatDateTime('hh:nn:ss', Now) + ' (' + MyProcess + ' - ' + MyTitle + ')';
             end;
    end;
end;

Zitat von himitsu:

Wenn das nicht für Windows kompiliert wird, dann meckert wirklich nicht der Compiler?

Kann man kaum glauben. Allein schon beim Anblick des GetWindowTitle.

Ich habe nicht behauptet es sei im jetzt-Zustand kompatibel zu irgendetwas anderem als Windows.
Ich habe lediglich die reinen Windows Methoden bereits aussortiert damit ein fähiger Linux oder MaxOS Kundiger gleich weiß wo es klemmt.

Die vielen IFDEF haben aber schon ein bissl impliziert, dass es so sein könnte.


An manchen Stellen zu viel und wo anders zu wenig.
z.B. LLen, ImageHeight und ImageWidth wären nicht initialisiert.

Und das eine Rect(,,,) ohne Parameter wird auch weinen.


Nja, da hier eh praktisch fast alles Windows ist, dann doch einfach die IFDEF weglassen, anstatt es komplet falsch zu lassen,
dazumal eh ein Alternativcode fehlt und selbst bei halbwegs richtigem ausgeifdeffe keine Funktion übrig bleibt.