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




　　 大家知道在VB下利用API函数Bitblt可以将屏幕或者窗口上的图像拷贝到VB中的PictureBox对象中，但是如果简单地利用PictureBox的SavePicture函数来保存图像，会发现什么也保存不了。这篇文章就是介绍如何捕获并利用Windows下的OLE API函数保存图像。
　　首先来看源程序，先建立一个新的工程文件，然后在Form1中加入5个CommandButton对象和一个PictureBox对象，然后在Form1中加入以下代码：
　　Option Explicit
　　Option Base 0
　　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
　　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 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 GetDeviceCaps Lib “GDI32" (ByVal hDC As Long, ByVal _iCapabilitiy As Long) 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 CreatePalette Lib “GDI32" (lpLogPalette As LOGPALETTE) _
　　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 GetForegroundWindow Lib “USER32" () As Long
　　Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette _
　　As Long, ByVal bForceBackground As Long) As Long
　　Private Declare Function RealizePalette Lib “GDI32" (ByVal hDC As Long) 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 ReleaseDC Lib “USER32" (ByVal hWnd As Long, ByVal hDC As _
　　Long) As Long
　　Private Declare Function GetDesktopWindow Lib “USER32" () As Long
　　Private Type PicBmp
　　Size As Long
　　Type As Long
　　hBmp As Long
　　hPal As Long
　　Reserved As Long
　　End Type
　　Private 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
　　'在两秒钟后捕捉当前的活动窗口
　　Private Sub Command2_Click()
　　MsgBox“当你关闭这个对话框两秒钟之后程序会捕捉处于活动状态的窗口。"
　　'等待两秒钟
　　Dim EndTime As Date
　　EndTime = DateAdd(“s", 2, Now)
　　Do Until Now > EndTime
　　DoEvents
　　Loop
　　Set Picture1.Picture = CaptureActiveWindow()
　　Me.SetFocus
　　End Sub
　　Private Sub Command3_Click()
　　Set Picture1.Picture = Nothing
　　End Sub
　　Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
　　Dim 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 = vbPicTypeBitmap
　　' 图像类型
　　.hBmp = hBmp
　　' 位图句柄
　　.hPal = hPal 
　　' 调色板句柄
　　End With
　　’建立Picture图像
　　r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
　　'返回Picture对象
　　Set CreateBitmapPicture = IPic
　　End Function
　　Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal _
　　LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc _
　　As Long) As Picture
　　Dim hDCMemory As Long
　　Dim hBmp As Long
　　Dim hBmpPrev As Long
　　Dim r 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 Client Then
　　hDCSrc = GetDC(hWndSrc)
　　Else
　　hDCSrc = GetWindowDC(hWndSrc)
　　End If
　　hDCMemory = CreateCompatibleDC(hDCSrc)
　　hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
　　hBmpPrev = SelectObject(hDCMemory, hBmp)
　　'获得屏幕属性
　　RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
　　HasPaletteScrn = RasterCapsScrn And RC_PALETTE
　　PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
　　'如果屏幕对象有调色板则获得屏幕调色板
　　If HasPaletteScrn And (PaletteSizeScrn = 256) Then
　　'建立屏幕调色板的拷贝
　　LogPal.palVersion = ＆H300
　　LogPal.palNumEntries = 256
　　r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
　　hPal = CreatePalette(LogPal)
　　'将新建立的调色板选如建立的内存绘图句柄中
　　hPalPrev = SelectPalette(hDCMemory, hPal, 0)
　　r = RealizePalette(hDCMemory)
　　End If
　　'拷贝图像
　　r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
　　hBmp = SelectObject(hDCMemory, hBmpPrev)
　　If HasPaletteScrn And (PaletteSizeScrn = 256) Then
　　hPal = SelectPalette(hDCMemory, hPalPrev, 0)
　　End If
　　'释放资源
　　r = DeleteDC(hDCMemor