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

　　r = ReleaseDC(hWndSrc, hDCSrc) 

　　Set CaptureWindow = createBitmapPicture(hBmp, hPal) 

　　End Function 

　　'capturescreen函数捕捉整个屏幕图像 

　　Public Function CaptureScreen() As Picture 

　　Dim hWndScreen As Long 

　　'获得桌面的窗口句柄 

　　hWndScreen = GetDesktopWindow() 

　　Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen. 

Width _ \ Screen.TwipsPerPixelX, Screen.Height \ Screen. 

TwipsPerPixelY) 

　　End Function 

　　Public Function CaptureActiveWindow() As Picture 

　　Dim hWndActive As Long 

　　Dim r As Long 

　　Dim RectActive As RECT 

　　hWndActive = GetForegroundWindow() 

　　r = GetWindowRect(hWndActive, RectActive) 

　　Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, _ 

　　RectActive.Right － RectActive.Left, RectActive.Bottom － 

RectActive.Top) 

　　End Function 

　　Public 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 

　　If Pic.Height >= Pic.Width Then 

　　Prn.Orientation = vbPRORPortrait 

　　Else 

　　Prn.Orientation = vbPRORLandscape 

　　End If 

　　PicRatio = Pic.Width / Pic.Height 

　　PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric) 

　　PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric) 

　　PrnRatio = PrnWidth / PrnHeight 

　　If PicRatio >= PrnRatio Then 

　　PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode) 

　　PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn. 

ScaleMode) 

　　Else 

　　PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode) 

　　PrnPicWidth = Prn.ScaleX(PrnHeight ＊ PicRatio, vbHiMetric, Prn. 

ScaleMode) 

　　End If 

　　Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight 

　　End Sub 

　　Private Sub Command4_Click() 

　　CommonDialog1.DefaultExt =“.BMP" 

　　CommonDialog1.Filter =“Bitmap Image (＊.bmp)|＊.bmp" 

　　CommonDialog1.ShowSave 

　　If CommonDialog1.FileName <> “" Then 

　　SavePicture Picture1.Picture, CommonDialog1.FileName 

　　End If 

　　End Sub 

　　Private Sub Command5_Click() 

　　PrintPictureToFitPage Printer, Picture1.Picture 

　　Printer.EndDoc 

　　End Sub 

　　Private Sub Form_Load() 

　　Command1.Caption = “捕捉整个屏幕" 

　　Command2.Caption = “两秒钟后捕捉活动窗口" 

　　Command3.Caption = “清除图像" 

　　Command4.Caption = “保存图像" 

　　Command5.Caption = “打印图像" 

　　End Sub 

　　运行程序，点击command1或者Command2就可以捕捉整个屏幕或者窗口到 

Picture1中，然后点击Command4或者Command5就可以保存或打印图像。 


　　上面的程序中最重要的是CaptureWindow函数以及createBitmapPicture函数， 

CaptureWindow函数建立与要捕捉的窗口的绘图设备（Device Context）句柄相兼 

容的绘图设备（Device Context）句柄，然后建立相应的调色板，最后将绘图设备 

（Device Context）中的图像拷贝到一个hBitmap对象句柄中。 

createBitmapPicture函数则根据传递过来的hBitmap对象句柄和调色板句柄建立一 

个Picture对象。再将这个对象赋予PictureBox的Picture属性，然后就可以使用 

SavePicture函数来保存图像了。 

　　OlecreatePictureIndirect函数支持的不仅有BMP图像，同时也支持Ico图标， 

所以利用该函数和ExtractIcon函数也可以提取并保存Windows文件中的图标。