Binaryworld - Capture Screen or any Active Window and print it to fit in one page ... [ VB -> Graphics ]

Step-By-Step Example

- Create a standard exe project
- Add 2 command button controls, one picturebox and one timer control on the form1
- Add the following code in form1

Click here to copy the following block

Option Explicit

Private Const INVERSE = 6
Private Const SOLID = 0
Private Const DOT = 2

Private HoldX As Single
Private HoldY As Single
Private StartX As Single
Private StartY As Single
Private SavedDrawStyle
Private SavedMode

Private Type PALETTEENTRY
  peRed As Byte
  peGreen As Byte
  peBlue As Byte
  peFlags As Byte
End Type

Private Type LOGPALETTE
  palVersion As Integer
  palNumEntries As Integer
  'Enough for 256 colors
  palPalEntry(255) As PALETTEENTRY
End Type

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Type PicBmp
  Size As Long
Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetActiveWindow Lib "USER32" () As Long
Private Declare Function GetForegroundWindow Lib "USER32" () As Long

Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long

Dim CAPTURE_TIME As Integer, Cnt As Integer

Private Function CaptureActiveWindow() As Picture
  On Error GoTo ErrorRoutineErr
  Dim R As RECT, hWndActive As Long, ret
  'Call CaptureWindow to capture the window by handle
  'given it's window
  'handle and then return the resulting Picture object
  'hWndActive = GetActiveWindow
  hWndActive = GetForegroundWindow

  If hWndActive = 0 Then Exit Function
  ret = GetWindowRect(hWndActive, R)
  Set CaptureActiveWindow = CaptureWindow(hWndActive, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, True)
  Exit Function
ErrorRoutineErr:
  MsgBox "CaptureForm" & Err & Error
  Resume Next
End Function

Private Function CaptureForm(MyForm As Form) As Picture
  On Error GoTo ErrorRoutineErr
  'Call CaptureWindow to capture the entire form
  'given it's window
  'handle and then return the resulting Picture object
  Set CaptureForm = CaptureWindow(MyForm.hWnd, 0, 0, MyForm.ScaleX(MyForm.Width, vbTwips, vbPixels), MyForm.ScaleY(MyForm.Height, vbTwips, vbPixels))
  Exit Function
ErrorRoutineErr:
  MsgBox "CaptureForm" & Err & Error
  Resume Next
End Function

Private Function CaptureWindow(ByVal hWndSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long, Optional ClientArea As Boolean = False) As Picture
  On Error GoTo ErrorRoutineErr

  Dim hDCMemory As Long
  Dim hBmp As Long
  Dim hBmpPrev As Long
  Dim rc As Long
  Dim hDCSrc As Long
  Dim hPal As Long
  Dim hPalPrev As Long
  Dim RasterCapsScrn As Long
  Dim HasPaletteScrn As Long
  Dim PaletteSizeScrn As Long

  Dim LogPal As LOGPALETTE

  If ClientArea = True Then
    'get device context for the window
    hDCSrc = GetDC(hWndSrc)
  Else
    'get device context for the window
    hDCSrc = GetWindowDC(hWndSrc)
  End If

  'Create a memory device context for the copy process
  hDCMemory = CreateCompatibleDC(hDCSrc)
  'Create a bitmap and place it in the memory DC
  hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
  hBmpPrev = SelectObject(hDCMemory, hBmp)

  'get screen properties
  'Raster capabilities
  RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
  'Palette support
  HasPaletteScrn = RasterCapsScrn And RC_PALETTE
  'Size of palette
  PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)

  'If the screen has a palette, make a copy
  'We need Palette for 256 colors
  If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    'Create a copy of the system palette
    LogPal.palVersion = &H300
    LogPal.palNumEntries = 256
    rc = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
    hPal = CreatePalette(LogPal)
    'Select the new palette into the memory
    'DC and realize it
    hPalPrev = SelectPalette(hDCMemory, hPal, 0)
    rc = RealizePalette(hDCMemory)
  End If

  'Copy the image into the memory DC
  rc = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

  'Remove the new copy of the on-screen image
  'hBmp = SelectObject(hDCMemory, hBmpPrev)

  'If the screen has a palette get back the palette that was
  'selected in previously
  If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    hPal = SelectPalette(hDCMemory, hPalPrev, 0)
  End If

  'Release the device context resources back to the system
  rc = DeleteDC(hDCMemory)
  rc = ReleaseDC(hWndSrc, hDCSrc)

  'Call CreateBitmapPicture to create a picture
  'object from the bitmap and palette handles.
  'then return the resulting picture object.
  Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
  Exit Function
ErrorRoutineErr:
  MsgBox "CaptureWindow" & Err & Error
  Resume Next
End Function

Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture

  On Error GoTo ErrorRoutineErr

  Dim R As Long
  Dim Pic As PicBmp
  'IPicture requires a reference to "Standard OLE Types"
  Dim IPic As IPicture
  Dim IID_IDispatch As GUID

  'Fill in with IDispatch Interface ID
  With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With

  'Fill Pic with necessary parts
  With Pic
    'Length of structure
    .Size = Len(Pic)
    'Type of Picture (bitmap)
    .Type = vbPicTypeBitmap
    'Handle to bitmap
    .hBmp = hBmp
    'Handle to palette (may be null)
    .hPal = hPal
  End With

  'Create Picture object
  R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

  'Return the new Picture object
  Set CreateBitmapPicture = IPic
  Exit Function
ErrorRoutineErr:
  MsgBox "CreateBitmapPicture" & Err & Error
  Resume Next
End Function

Private Sub PrintPicture(MyPrinter As Printer, MyPicture As Picture)
  On Error GoTo ErrorRoutineErr
  MyPrinter.PaintPicture MyPicture, 0, 0
  Exit Sub
ErrorRoutineErr:
  MsgBox "PrintPicture" & Err & Error
  Resume Next
End Sub

Private Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)
  Const vbHiMetric As Integer = 8
  Dim PicRatio As Double
  Dim PrnWidth As Double
  Dim PrnHeight As Double
  Dim PrnRatio As Double
  Dim PrnPicWidth As Double
  Dim PrnPicHeight As Double
  ' Determine if picture should be printed in landscape or portrait and
  ' set the orientation
  If Pic.Height >= Pic.Width Then
    Prn.Orientation = vbPRORPortrait  ' Taller than wide
  Else
    Prn.Orientation = vbPRORLandscape  ' Wider than tall
  End If
  ' Calculate device independent Width to Height ratio for picture
  PicRatio = Pic.Width / Pic.Height
  ' Calculate the dimentions of the printable area in HiMetric
  PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)
  PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)
  ' Calculate device independent Width to Height ratio for printer
  PrnRatio = PrnWidth / PrnHeight
  ' Scale the output to the printable area
  If PicRatio >= PrnRatio Then
    ' Scale picture to fit full width of printable area
    PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
    PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, _
        Prn.ScaleMode)
  Else
    ' Scale picture to fit full height of printable area
    PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
    PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, _
        Prn.ScaleMode)
  End If
  ' Print the picture using the PaintPicture method
  Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight
End Sub

'Usage: Print form
Private Sub Command1_Click()
  Set Picture1.Picture = CaptureForm(Me)

  '//Print it to fit in one page
  'PrintPictureToFitPage Printer, Picture1.Picture
  'Printer.EndDoc
End Sub

Private Sub Command2_Click()
  Timer1.Enabled = True
End Sub

Private Sub Form_Load()
  Timer1.Enabled = False
  Timer1.Interval = 1000
  Command1.Caption = "Capture Form"
  Command2.Caption = "Capture Active Window (After 6 Sec)"
  Picture1.AutoRedraw = True
  Cnt = 0
  CAPTURE_TIME = 6
End Sub

Private Sub Timer1_Timer()
  Cnt = Cnt + 1
  If Cnt >= CAPTURE_TIME Then
    Set Picture1.Picture = CaptureActiveWindow
    MsgBox "Screenshot Taken"
    Timer1.Enabled = False
    Cnt = 0
  End If
End Sub