大家知道在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