利用VB捕捉并保存屏幕图象

1、    大家知道在VB下利用API函数Bitblt可以将屏幕或者窗口上的图象拷贝到VB中的PictureBox对象中,但是如果简单的利用PictureBox的SavePicture函数来保存图象，会发现什么也保存不了。这篇文章就是介绍如何捕获并利用Windows下的OLE API函数保存图象。首先来看源程序，首先建立一个新的工程文件，然后在Form1中加入5个CommandButton对象和一个PictureBox对象，然后在Form1中加入以下代码：Option ExplicitOption Base 0Private Type PALETTEENTR

2、Y peRed As Byte peGreen As Byte peBlue As Byte peFlags As ByteEnd TypePrivate Type LOGPALETTE palVersion As Integer palNumEntries As Integer palPalEntry(255) As PALETTEENTRYEnd TypePrivate Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As ByteEnd TypePrivate Const RASTERCAPS As L

3、ong = 38Private Const RC_PALETTE As Long = &H100Private Const SIZEPALETTE As Long = 104Private Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypePrivate Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As LongPrivate Declare Function CreateCompat

4、ibleBitmap Lib "GDI32" (ByVal hDC As Long, _ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal _iCapabilitiy As Long) As LongPrivate Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal

5、 hDC As Long, _ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries _As PALETTEENTRY) As LongPrivate Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) _As LongPrivate Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObje

6、ct _As Long) As LongPrivate 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 LongPrivate Declare Functi

7、on DeleteDC Lib "GDI32" (ByVal hDC As Long) As LongPrivate Declare Function GetForegroundWindow Lib "USER32" () As LongPrivate Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette _As Long, ByVal bForceBackground As Long) As LongPrivate Declare

8、Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As LongPrivate Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As LongPrivate Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As LongPrivate Declare Function GetWindowRect Lib "USER32&q

9、uot; (ByVal hWnd As Long, lpRect As _RECT) As LongPrivate Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As _Long) As LongPrivate Declare Function GetDesktopWindow Lib "USER32" () As LongPrivate Type PicBmp Size As Long Type As Long hBmp As Long hPal As Lo

10、ng Reserved As LongEnd TypePrivate Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As _PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long注释：捕捉整个屏幕Private Sub Command1_Click() Set Picture1.Picture = CaptureScreen()End Sub注释：在两秒钟后捕捉当前的活动

11、窗口Private Sub Command2_Click()MsgBox "当你关闭这个对话框两秒钟之后程序会捕捉处于活动状态的窗口."注释：等待两秒钟Dim EndTime As DateEndTime = DateAdd("s", 2, Now)Do Until Now > EndTime DoEvents LoopSet Picture1.Picture = CaptureActiveWindow()Me.SetFocusEnd SubPrivate Sub Command3_Click()Set Picture1.Picture = Not

12、hingEnd SubPublic Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As PictureDim r As Long Dim Pic As PicBmp Dim IPic As IPicture Dim IID_IDispatch As GUID 注释：填充IDispatch界面 With IID_IDispatch.Data1 = &H20400.Data4(0) = &HC0.Data4(7) = &H46 End With 注释：填充Pic With Pic.Size = Len(Pic)注释： Pic结构长度.Type = vbPicTypeBitma