图片调用VBA公用代码

hzhb14796

• 问题1 请问能否将从工作表中截获的图片（对Range进行了CopyPicture操作）直接放入UserForm的TextBox里（该窗体并非在工作表中建立的，而是在工程中建立的）？如果不可行，有无其他方式实现？
• 问题2 同样对于一个Range进行了CopyPicture和Paste操作后，能否将截获的图片直接放入单元格的批注中？在实现过程中是否必须要将截获的图片导出并保存为图片格式（比如gif）的文件后，才能再对批注进行Fill操作？若不可行，有无其他方式实现？
• 问题3 将Excel多个选定的数据区域分别导出为图片的VBA代码
• 其实，问题的关键在于如何获取Excel工作表中的图片供使用。在Excel中，Chart对象有一个Export方法，能够直接将图形以图像方式导出到本地计算机上，例如将工作表Sheet1中的第1个图表导出为GIF图像并保存到C：盘，其VBA代码为：
  Worksheets("Sheet1").ChartObjects(1) .Chart.Export _
      FileName:="C:\MyChart.gif", FilterName:="GIF"
  然而，有时候我们需要将工作表中的图片（Picture）或形状（Shape）导出到文件夹中，此时就没那么容易了。我尝试过将图片或形状复制到Excel图表区域（先使图表区域为空，再将图片复制到此区域），然后再使用其Export方法将图片导出，但没有成功（这是一个思路，不知道哪位朋友试过且成功了，可以在这里与大家分享）。
  没办法，只好使用Windows API了，在查阅了一些图书和资料后，终于找到了这样的代码。在这里，将通用的代码贴出来，与大家分享。同时，以简单的示例代码演示其使用方法。
• 示例1：将Excel单元格区域复制为图片，然后从剪贴板中取出该图片并放入单元格批注中这是《Excel 2007 VBA参考大全》作者之一Stephen Bullen编写的一段通用代码，您可以将其当作通用模块在自已的工程中使用（当然，您不必理解其含义，能用就行了，呵呵……）。
  ModPastePicture模块代码：
  '***************************************************************************
  '*
  '* 模 块 名 称:   粘贴图片
  '* 作者 & 日期:   STEPHEN BULLEN, Office Automation Ltd
  '*                1998年11月15日
  '*
  '* 联 系 方 式:   Stephen@oaltd.co.uk
  '* 网 站 地 址:   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
  
  

该贴已经同步到 hzhb14796的微博

hzhb14796

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 过程: CreatePicture
'''
''' 用途: 将图像(和调色板)句柄转换为Picture对象.
'''
'''       需要引用"OLE Automation"类型库
'''
''' 参数: 无
'''
''' 日期          开发者           修订记录
''' --------------------------------------------------------------------------
''' 98年10月30日  Stephen Bullen   创建
'''

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture

    ' IPicture需要引用"OLE Automation"
    Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture

    'OLE图片类型
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ENHMETAFILE = 4

    ' 创建接口GUID (IPicture接口)
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    ' 填充uPicInfo
    With uPicInfo
        .Size = Len(uPicInfo)                                                   ' 结构的长度.
        .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)  ' Picture类型
        .hPic = hPic                                                            ' 图像句柄
        .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)                              ' 调色板句柄(bitmap)
    End With

    ' 创建Picture对象.
    r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

    ' 如果发生错误,则显示错误描述
    If r <> 0 Then Debug.Print "创建图片: " & fnOLEError(r)

    ' 返回新的Picture对象.
    Set CreatePicture = IPic

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 过程: fnOLEError
'''
''' 用途: 获取代表标准OLE错误的消息文本
'''
''' 参数: 无
'''
''' 日期           开发者              修订记录
''' --------------------------------------------------------------------------
''' 98年10月30日   Stephen Bullen      创建
'''

Private Function fnOLEError(lErrNum As Long) As String

    'OLECreatePictureIndirect返回值
    Const E_ABORT = &H80004004
    Const E_ACCESSDENIED = &H80070005
    Const E_FAIL = &H80004005
    Const E_HANDLE = &H80070006
    Const E_INVALIDARG = &H80070057
    Const E_NOINTERFACE = &H80004002
    Const E_NOTIMPL = &H80004001
    Const E_OUTOFMEMORY = &H8007000E
    Const E_POINTER = &H80004003
    Const E_UNEXPECTED = &H8000FFFF
    Const S_OK = &H0

    Select Case lErrNum
        Case E_ABORT
            fnOLEError = " 终止"
        Case E_ACCESSDENIED
            fnOLEError = " 拒绝访问"
        Case E_FAIL
            fnOLEError = " 失败"
        Case E_HANDLE
            fnOLEError = " 丢失/缺失句柄"
        Case E_INVALIDARG
            fnOLEError = " 无效参数"
        Case E_NOINTERFACE
            fnOLEError = " 没有接口"
        Case E_NOTIMPL
            fnOLEError = " 没有执行"
        Case E_OUTOFMEMORY
            fnOLEError = " 内存溢出"
        Case E_POINTER
            fnOLEError = " 无效指针"
        Case E_UNEXPECTED
            fnOLEError = " 未知错误"
        Case S_OK
            fnOLEError = " 成功!"
    End Select

End Function
下面将应用该通用模块提供的功能从剪贴板中提取图片，并将其放置到单元格批注中，最后从文件夹中删除该图片。注意，代码使用了CopyPicture方法将单元格区域复制为图片。
首先，声明公共变量：
Dim vFile As Variant
输入下列代码并运行，以获取图片：
Sub SaveAsPicture()
    Dim lPicType As Long, oPic As IPictureDisp

    '获取要保存图片的文件名称
    vFile = Application.GetSaveAsFilename(InitialFileName:="", _
               FileFilter:="BMP文件 (*.bmp), *.bmp")
    If vFile <> False Then
        '将单元格区域B2:C4复制为图片
        Sheet1.Range("B2:C4").CopyPicture
        Set oPic = PastePicture
        '将图片保存到文件中
        '如果剪贴板中没有图片则给出消息提示
        If Not oPic Is Nothing Then
            SavePicture oPic, vFile
        Else
            MsgBox "剪贴板中没有图片.", vbInformation, "粘贴图片 ..."
        End If
    Else
        MsgBox "没有指定文件名.", vbInformation, "粘贴图片 ..."
    End If
End Sub
输入下列代码并运行后，图片将被放到单元格批注中，然后删除文件夹中的图片：
Sub PutPictureInRangeComment()
    Dim rng As Range
    Set rng = Sheet1.Range("E2")
    On Error Resume Next
    rng.Comment.Delete
    On Error GoTo 0
    With rng.AddComment
        With .Shape
            .Height = 40
            .Width = 80
            .Fill.UserPicture vFile
        End With
        .Visible = True
    End With
    '删除图片文件
    Kill vFile
    '释放对象变量
    Set rng = Nothing
End Sub
运行后的结果如下图1所示：

图1：将单元格区域图片放置到单元格批注中
示例文档下载：

示例2：将Excel单元格区域复制为图片，然后从剪贴板中取出该图片并放入用户窗体的图像控件中
本示例也可以使用上述ModPastePicture模块代码来完成，但这里另外提供了一段相似的代码。在VBE中插入一标准模块，并输入下面的代码：
Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc,  _
RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long,  _
ByVal lpszFile As String) As Long
Private 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

Function PictureFromObject(Target As Object) As IPictureDisp
    Dim hPtr As Long, PicType As Long, hCopy As Long

    Const CF_BITMAP = 2
    Const CF_PALETTE = 9
    Const CF_ENHMETAFILE = 14
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ENHMETAFILE = 4
    Target.CopyPicture
    PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
    If IsClipboardFormatAvailable(PicType) <> 0 Then
        If OpenClipboard(0) > 0 Then
            hPtr = GetClipboardData(PicType)
            If PicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
            CloseClipboard
            If hPtr <> 0 Then
                Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp

                With IID_IDispatch
                    .Data1 = &H7BF80980
                    .Data2 = &HBF32
                    .Data3 = &H101A
                    .Data4(0) = &H8B
                    .Data4(1) = &HBB
                    .Data4(2) = &H0
                    .Data4(3) = &HAA
                    .Data4(4) = &H0
                    .Data4(5) = &H30
                    .Data4(6) = &HC
                    .Data4(7) = &HAB
                End With

                With uPicInfo
                    .Size = Len(uPicInfo)
                    .Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
                    .hPic = hCopy
                End With

                OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
                Set PictureFromObject = IPic
            End If
        End If
    End If
End Function
然后，在VBE中插入用户窗体，在其中放置一个图像控件和一个按钮，并在用户窗体代码模块中输入下列代码：
Private Sub CommandButton1_Click()
    Dim rng As Range
    Set rng = Sheet1.Range("B2:C4")
    Set Image1.Picture = PictureFromObject(rng)
    Set rng = Nothing
End Sub
此时，运行用户窗体并单击按钮后如图2所示。

图2：将单元格区域图片放置到用户窗体中
当然，也可以使用上述模块实现示例1的功能。例如，下面的代码将工作表中的图片输出到指定位置：
'将工作表中的图片输出到指定位置
Sub Example()
    '保存图像或形状
    SavePicture PictureFromObject(Sheet1.Pictures("Picture 1")), "C:\Picture 1.bmp"
    '保存形状
    SavePicture PictureFromObject(Sheet1.Shapes("WordArt 1")), "C:\WordArt 1.gif"
    '保存单元格区域
    SavePicture PictureFromObject(Sheet1.Range("B2:C4")), "C:\RangeB2_C4.jpg"

hzhb14796

另一种方法，由chijanzen 提供的代码   先將工作表中的圖片匯出為*.jpg檔，然後再使用LoadPicture方法載入Image 控件，最後再將該暫存檔刪除
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
Type As Long
    hPic As Long
    hPal As Long
End Type
Private Declare Function IsClipboardFormatAvailable Lib "user32" ( _
        ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" ( _
        ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" ( _
        ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
        PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
        IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
        ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private 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
Private Sub UserForm_Activate()
    Me.ComboBox1.ListIndex = 0
End Sub
Private Sub UserForm_Initialize()
Dim pic As Shape
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture Then
            Me.ComboBox1.AddItem pic.Name
        End If
    Next pic
End Sub
Private Sub ComboBox1_Change()
    rTemp = ThisWorkbook.Path & "\" & Me.ComboBox1.Text & ".jpg"
    'save a shape
    SavePicture PictureFromObject(ActiveSheet.Shapes(Me.ComboBox1.Text)), rTemp
    Me.Image1.Picture = LoadPicture(rTemp)
    '等待10秒後刪除
    Dim rtime As Date
    rtime = DateAdd("s", 10, Now())
    Kill rTemp
End Sub
Function PictureFromObject(Target As Object) As IPictureDisp
Dim hPtr As Long, PicType As Long, hCopy As Long
Const CF_BITMAP = 2

Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
    '將shape圖片複製到剪貼簿(以BITMAP 圖片的格式複製)
    Target.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    '檢測剪貼板內資料的類型
    PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, _
            CF_BITMAP, CF_ENHMETAFILE)
    If IsClipboardFormatAvailable(PicType) <> 0 Then
        If OpenClipboard(0) > 0 Then
            hPtr = GetClipboardData(PicType)
            If PicType = CF_BITMAP Then
                '複製圖片並以BITMAP 圖片格式同時轉換為檔案
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                '複製圖片並以ENHMETAFILE 圖片格式同時轉換為檔案
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
            CloseClipboard
            If hPtr <> 0 Then
                Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, _
                        IPic As IPictureDisp
                With IID_IDispatch
                    .Data1 = &H7BF80980
                    .Data2 = &HBF32
                    .Data3 = &H101A
                    .Data4(0) = &H8B
                    .Data4(1) = &HBB
                    .Data4(2) = &H0
                    .Data4(3) = &HAA
                    .Data4(4) = &H0
                    .Data4(5) = &H30
                    .Data4(6) = &HC
                    .Data4(7) = &HAB
                End With
                With uPicInfo
                    .Size = Len(uPicInfo)
                    .Type = IIf(PicType = CF_BITMAP, _
                            PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
                    .hPic = hCopy
                End With
                OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
                Set PictureFromObject = IPic
            End If
        End If
    End If
End Function

hzhb14796

这一种不需要保存为文件，能直接调用
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Public Function LoadShapePicture(shp As Object) As IPictureDisp
    Dim nClipsize As Long
    Dim hMem As Long
    Dim lpData As Long
    Dim sdata() As Byte
    Dim fmt As Long
    Dim fmtName As String
    Dim iClipBoardFormatNumber As Long
    Dim IID_IPicture(15)
    Dim istm As stdole.IUnknown
   
    If TypeName(shp) = "ChartObject" Then
        shp.CopyPicture xlPrinter
        Sheet1.Paste
        Selection.Cut
    Else
        shp.Copy
    End If
   
    OpenClipboard 0&
    If iClipBoardFormatNumber = 0 Then
        fmt = EnumClipboardFormats(0)
        Do While fmt <> 0
            fmtName = Space(255)
            GetClipboardFormatName fmt, fmtName, 255
            fmtName = Trim(fmtName)
            If fmtName <> "" Then
                fmtName = Left(fmtName, Len(fmtName) - 1)
                If fmtName = "GIF" Then
                    iClipBoardFormatNumber = fmt
                    Exit Do
                End If
            End If
            fmt = EnumClipboardFormats(fmt)
         Loop
    End If

    hMem = GetClipboardData(iClipBoardFormatNumber)
    If CBool(hMem) Then
        nClipsize = GlobalSize(hMem)
        lpData = GlobalLock(hMem)
        GlobalUnlock hMem
        If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
                If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
                   Call OleLoadPicture(ByVal ObjPtr(istm), nClipsize, 0, IID_IPicture(0), LoadShapePicture)
                End If
        End If
    End If

    EmptyClipboard
    CloseClipboard

  End Function

谁偷了我的QQ

支持，不过看的不怎么董

joyark

已经下载了，谢谢分享

啊锋

多谢楼主分享，我目前正在学习图片处理方面的代码，正好可以下来学一下，上面的代码也复制保存了，非常感谢！

wfy_lhl

已经下载了，谢谢分享

bmdsjxyw

居然还有这样的技术，学习了

aman1516

太强了，这委好的贴子，正需要，收藏学习，谢谢分享！！