Thursday, September 10, 2009

Take a screenshot?

Need to take a screenshot?
Here's the code
// get a desired rect screenshot //
procedure ScreenshotArea(
  var theBitmap: TBitmap;
  const thisArea: TRect;
  const IncludeCursor: Boolean = False);
const
  CDESKTOP_HWND = 0;
var
  hdcDesktop: HDC;
  theCursorInfo: TCursorInfo;
  theIcon: TIcon;
  theIconInfo: TIconInfo;
begin
  theBitmap.Width  := thisArea.Right -thisArea.Left;
  theBitmap.Height := thisArea.Bottom -thisArea.Top;
  hdcDesktop := GetWindowDC(CDESKTOP_HWND);
  BitBlt(
    theBitmap.Canvas.Handle,
    0,
    0,
    thisArea.Right,
    thisArea.Bottom,
    hdcDesktop,
    thisArea.Left,
    thisArea.Top,
    SRCCOPY);
  theBitmap.Modified := True;
  ReleaseDC(CDESKTOP_HWND, hdcDesktop);
  if IncludeCursor then begin  
    theIcon := TIcon.Create;
    try
      theCursorInfo.cbSize := SizeOf(theCursorInfo);
      if GetCursorInfo(theCursorInfo) then
        if theCursorInfo.flags = CURSOR_SHOWING then begin
          theIcon.Handle := CopyIcon(theCursorInfo.hCursor);
          if GetIconInfo(theIcon.Handle, theIconInfo) then
            try
              theBitmap.Canvas.Draw(
                theCursorInfo.ptScreenPos.x
                  -Integer(theIconInfo.xHotspot) -thisArea.Left,
                theCursorInfo.ptScreenPos.y
                  -Integer(theIconInfo.yHotspot) -thisArea.Top, theIcon);
            finally
              DeleteObject(theIconInfo.hbmMask);
              DeleteObject(theIconInfo.hbmColor);
            end;
        end;
    finally
      theIcon.Free;
    end;
  end;
end;

// take a screenshot of active window //
procedure ScreenshotActiveWindow(
  var theBitmap: TBitmap;
  const IncludeCursor: Boolean = True);
var
  WindowRect: TRect;
  hwndForegroundWindow: HWND;
begin
  hwndForegroundWindow := GetForegroundWindow;
  GetWindowRect(hwndForegroundWindow, WindowRect);
  ScreenshotArea(theBitmap, WindowRect, IncludeCursor);
end;

Usage
// example of taking active window's screenshot //
procedure TForm1.Button1Click(Sender: TObject);
var
  thisBitmap: TBitmap;
begin
  thisBitmap := TBitmap.Create;
  ScreenshotActiveWindow(thisbitmap, True);
  Image1.Picture.Assign(thisBitmap);
  FreeAndNil(thisBitmap);
end;

// example of taking full screenshot //

procedure TForm1.Button1Click(Sender: TObject);
var
  thisBitmap: TBitmap;
begin
  thisBitmap := TBitmap.Create;
  ScreenshotArea(thisBitmap, Screen.DesktopRect, True);
  Image1.Picture.Assign(thisBitmap);
  FreeAndNil(thisBitmap);
end;

No comments:

Post a Comment

Blogroll(General programming and Delphi feeds)