{$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;