网页功能: 加入收藏 设为首页 网站搜索  
利用VB捕捉并保存屏幕图像
发表日期:2003-07-21作者:[] 出处:  

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

我来说两句】 【加入收藏】 【返加顶部】 【打印本页】 【关闭窗口
中搜索 利用VB捕捉并保存屏幕图像
本类热点文章
  在VB中使用WMI获取系统硬件和软件有关信..
  将繁体中文字转化成简体中文
  获取CPU的ID
  在vb程序中如何获取剪贴板中所复制的文..
  更新桌面图片
  VB编程破解Windows屏幕保护密码
  让程序的鼠标支持滚轮
  用VB创建Windows快捷方式(无需DLL)
  用vb调用系统输入法
  用VB制作IE工具条自定义按钮
  修改显示器的刷新频率
  vb实现多线程
最新分类信息我要发布 
最新招聘信息

关于我们 / 合作推广 / 给我留言 / 版权举报 / 意见建议 / 广告投放  
Copyright ©2003-2019 Lihuasoft.net webmaster(at)lihuasoft.net
网站编程QQ群   京ICP备05001064号 页面生成时间:0.00577