[VBnet Bitmaps] OleCreatePictureIndirect: Mimicking PrintScreen Using OLE


	Visual Basic Bitmap Routines OleCreatePictureIndirect: Mimicking PrintScreen Using OLE

Posted:	Friday December 27, 1996
Updated:	Monday December 26, 2011

Applies to:	VB4-32, VB5, VB6
Developed with:	VB4-32, Windows 95
OS restrictions:	None
Author:	VBnet - Randy Birch

Related:	BitBlt: Mimicking the PrintScreen Function BitBlt: Mimicking PrintScreen to Create a 'PrintForm' CreateEnhMetaFile: Saving a PrintScreen as a Windows Enhanced Metafile InflateRect: Highlighting External Windows keybd_event: Calling Windows' PrintScreen Function OleCreatePictureIndirect: Mimicking PrintScreen Using OLE

Prerequisites

None.

This code makes use of the OLE standard interface in Windows95/Windows98 to copy the contents of the desktop (the screen) into a PictureBox and save it to disk. To use this code, you must assure that the Standard OLE Types Reference to file \Windows\System\OLEPRO32.DLL is included in the project's references (Tools Menu/References).

BAS Module Code

None.

Form Code

On a form, add a command button (Command1) and a picture box (Picture1). Add the following code to the form:

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Base 0
         
Private Type GUID  
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
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 GetDesktopWindow Lib "user32" () As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
   (ByVal hdc 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 SelectObject Lib "gdi32" _
   (ByVal hdc As Long, ByVal hObject As Long) As Long

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 DeleteDC Lib "gdi32" _
   (ByVal hdc As Long) As Long

Private Declare Function GetWindowDC Lib "user32" _
   (ByVal hWnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
   (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
   (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long



Private Sub Command1_Click()

   Set Picture1.Picture = GetOLEScreenSnapshot()
   
  'Remove the comment on the next line to
  'save the picture to disk. Assure that the
  'path provided is valid for your system.
  'SavePicture Picture1, "d:\test.bmp"

End Sub


Private Function GetOLEScreenSnapshot() As Picture

    Dim hWndSrc As Long
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim WidthSrc As Long
    Dim HeightSrc As Long   
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
   
  'CaptureWindow   
   WidthSrc = Screen.Width \ Screen.TwipsPerPixelX
   HeightSrc = Screen.Height \ Screen.TwipsPerPixelY
   
  'Get a handle to the desktop window and get the proper device context
   hWndSrc = GetDesktopWindow()
   hDCSrc = GetWindowDC(hWndSrc) 
   
  '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)
    
  'Copy the on-screen image into the memory DC
   Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, _
               hDCSrc, 0, 0, vbSrcCopy)
   
  'Remove the new copy of the the on-screen image
   hBmp = SelectObject(hDCMemory, hBmpPrev)
   
  'Release the device context resources back to the system
   Call DeleteDC(hDCMemory)
   Call ReleaseDC(hWndSrc, hDCSrc)
   
  'Fill in OLE IDispatch Interface ID
   With IID_IDispatch
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
    End With
   
 'Fill Pic with necessary parts
  With Pic
      .Size = Len(Pic)         'Length of structure
      .Type = vbPicTypeBitmap  'Type of Picture (bitmap)
      .hBmp = hBmp             'Handle to bitmap
      .hPal = 0&               'Handle to palette (may be null)
    End With
   
  'Create OLE Picture object   
   Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
   
  'Return the new Picture object   
   Set GetOLEScreenSnapshot = IPic

End Function

Comments

PayPal Link