How to capture a piece of the desktop

• Download source code - 26.7 KB

Introduction

Here is a utility with which you can copy pieces of the desktop, and either paste the image somewhere or save it as an image file.

Background

I use this utility when, for example creating, documentation.

Using the code

Run the code. Press down the primary mouse button. The cursor changes to a +. Move the mouse so that the + is positioned on the upper left corner of the area you need to capture. Press the secondary mouse button while still having the other button depressed. Drag a rectangle and let go of the buttons. A SaveFileDialog appears. If you don't want to save the image, click Cancel. The image is always tucked in the clipboard, so you can just paste it in whatever document you have open.

API-declarations:

Private Declare Function SetCapture Lib "user32" (ByVal hWnd As IntPtr) As Int32
Private Declare Function ReleaseCapture Lib "user32" () As Int32

Private Declare Auto Function CreateDC Lib "Gdi32" Alias "CreateDC" _
    (ByVal lpDriverName As String, _
     ByVal lpDeviceName As String, _
     ByVal lpOutput As String, _
     ByVal lpInitData As IntPtr) As IntPtr

Private Declare Function SelectObject Lib "gdi32" _
    (ByVal dc As IntPtr, ByVal hObject As Int32) As Int32

Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Int32) As Int32

Private Declare Function SetROP2 Lib "gdi32" _
    (ByVal dc As IntPtr, ByVal nDrawMode As Int32) As Int32

Private Declare Function Rectangle Lib "gdi32" _
    (ByVal dc As IntPtr, ByVal x1 As Int32, ByVal y1 As Int32, _
     ByVal X2 As Int32, ByVal Y2 As Int32) As Int32

Private Declare Function DeleteDC Lib "gdi32" (ByVal dc As IntPtr) As Int32
Private Const NULL_BRUSH As Int32 = 5
Private Const R2_NOT As Int32 = 6
Private Const R2_NOTXORPEN As Int32 = 10

Private Structure POINTAPI
    Dim X As Int32
    Dim Y As Int32
End Structure

Does anyone know if POINTAPI is in the framework?

Drawing the rectangle:

'get the cursor position
ptNow.X = Cursor.Position.X
ptNow.Y = Cursor.Position.Y
'draw the rectangle  
Rectangle(dc, ptAnchor.X, ptAnchor.Y, ptNow.X, ptNow.Y)
'remove the previous rectangle 
Rectangle(dc, ptAnchor.X, ptAnchor.Y, ptOld.X, ptOld.Y)

Copying the image:

Dim Image As Bitmap
Const SRCCOPY As Integer = &HCC0020
Dim sdlgImage As New SaveFileDialog

'get size of rectangle
nWidth = Math.Abs(ptAnchor.X - ptNow.X)
nHeight = Math.Abs(ptAnchor.Y - ptNow.Y)
With picImage
  'scale picture box on form
  .Width = nWidth
  .Height = nHeight

  Dim g As Graphics = .CreateGraphics
  'create an empty image of adequate size
  Image = New Bitmap(nWidth, nHeight, g)
  'create new graphics from image
  g = Graphics.FromImage(Image)
  'get the windows handle
  Dim deviceContext2 As IntPtr = g.GetHdc
  'copy the image from screen into the image variable
  BitBlt(deviceContext2, 0, 0, nWidth, nHeight, dc, _
         ptAnchor.X, ptAnchor.Y, SRCCOPY)
  'release resources
  g.ReleaseHdc(deviceContext2)
  'put the image into the picturebox
  .Image = Image
  'this might be unnecessary
  .Refresh()
  .Visible = True
  'put image into clipboard
  Clipboard.SetDataObject(.Image)
End With

Try
  With sdlgImage
    .FileName = "Image"
    .Filter = "Bitmap (*.bmp)|*.bmp|JPEG (*.jpg, *.jpeg)|*.jpg;" & _ 
              "*.jpeg|GIF (*.gif)|*.gif|TIFF (*.tif, *.tiff)|*.tif;" & _ 
              "*.tiff|PNG (*.png)|*.png"
    .AddExtension = True
    .OverwritePrompt = True
    .CheckPathExists = True
    .ValidateNames = True
    .Title = "Save Image"
    If .ShowDialog() = DialogResult.OK Then
      Dim bmp As New Bitmap(picImage.Image)
      Dim fmt As Imaging.ImageFormat
      Select Case .FilterIndex
        Case 1
              fmt = Imaging.ImageFormat.Bmp
            Case 2
              fmt = Imaging.ImageFormat.Jpeg
            Case 3
              fmt = Imaging.ImageFormat.Gif
            Case 4
              fmt = Imaging.ImageFormat.Tiff
            Case 5
              fmt = Imaging.ImageFormat.Png
            Case Else
              fmt = Imaging.ImageFormat.Bmp
          End Select
          bmp.Save(.FileName, fmt)
        End If
  End With
Catch e As Exception
  MessageBox.Show(e.Message, "Saving Image")
End Try