示例1:将Excel单元格区域复制为图片,然后从剪贴板中取出该图片并放入单元格批注中这是《Excel 2007 VBA参考大全》作者之一Stephen Bullen编写的一段通用代码,您可以将其当作通用模块在自已的工程中使用(当然,您不必理解其含义,能用就行了,呵呵……)。
ModPastePicture模块代码:
'***************************************************************************
'*
'* 模 块 名 称: 粘贴图片
'* 作者 & 日期: STEPHEN BULLEN, Office Automation Ltd
'* 1998年11月15日
'*
'* 网 站 地 址: http://www.oaltd.co.uk
'*
'* 说 明: 从剪贴板中创建标准的Picture对象.
'* 该对象能赋给用户窗体中的图像(Image)控件
'* PastePicture函数接受代表图片类型的可选参数 - xlBitmap or xlPicture.
'*
'* 代码需要引用"OLE Automation"类型库
'*
'* 代码来源于MSDN中发现的一些资料.
'*
'* 要使用这段代码,只需将该模块导入到您的工程中,然后使用:
'* Set Image1.Picture = PastePicture(xlPicture)
'* 将剪贴板中的图片粘贴到标准的图像控件中.
'*
'* 过程:
'* PastePicture 程序入口
'* CreatePicture 私有函数来将bitmap或metafile句柄转换为OLE引用
'* fnOLEError 为OLE错误代码获取错误文本
'***************************************************************************
Option Explicit
Option Compare Text
''' 用户定义类型以便API调用
'声明UDT来为IPicture OLE接口储存GUID
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'声明UDT储存bitmap信息
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'''Windows API函数声明
'剪贴板包括bitmap/metafile吗?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'打开剪贴板读取
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'获取bitmap/metafile指针
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'关闭剪贴板
Private Declare Function CloseClipboard Lib "user32" () As Long
'将句柄转换到OLE IPicture接口里.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, _
RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'创建自已的metafile副本,以便不会因为随后剪贴板的更新而擦除
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'创建自已的bitmap副本,以便不会因为随后剪贴板的更新而擦除
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, _
ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'我们要使用的API格式类型
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 过程: PastePicture
'''
''' 用途: 获取在剪贴板中的Picture对象
'''
''' 参数: lXlPicType - 要创建的图片类型,为下列类型之一:
''' xlPicture是创建metafile (默认)
''' xlBitmap是创建bitmap
'''
''' 日期 开发者 修订记录
''' --------------------------------------------------------------------------
''' 98年10月30日 Stephen Bullen 创建
''' 98年11月15日 Stephen Bullen 更新以创建自已的剪贴板图像副本
'''
Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
'一些指针
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
'将xl常量的图片类型转换为API常量
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'检查剪贴板是否包含所需的格式
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
'获取对剪贴板的访问
h = OpenClipboard(0&)
If h > 0 Then
'获取图像数据句柄
hPtr = GetClipboardData(lPicType)
'以合适的格式创建自已的剪贴板中图像的副本
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
'对其它程序释放剪贴板
h = CloseClipboard
'如果获取了图像句柄,将其转换为Picture对象并返回
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function