VBA: IMAGE控件加载工作表中的图片

leon620

一般VBA IMAGE控件加载图片都是采用图片库文件夹的方式，代码一般如下所示：
Private Sub TextBox1_Change()
On Error Resume Next
Image1.Picture = LoadPicture(ThisWorkbook.Path & "/图片库/" & TextBox1.Text & ".jpg")
End Sub

但是现在需要VBA: IMAGE控件加载工作表中的图片，请问各位如何进行？
在网上找到一段代码，但是看不懂，请高手批注，谢谢。


代码中提供了一个函数：
LoadShapePicture(shp As Object)
它的使用方法与LoadPicture(FileName)类似，只不过参数中的shp指向的是工作表图形或图表。
Option Explicit     
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

初始化显示企鹅图片---->对话框输入“企鹅”，点击回车--->程序判断对错，正确则显示下一张图片，错误则弹出提示框，并清除对话框中的内容，图片依旧是“企鹅”不变。

解0人

↓↓↓↓↓↓↓↓↓↓↓↓

doul123

1. http://club.excelhome.net/thread-372773-1-1.html

复制代码

leon620

解0人 发表于 2016-2-22 11:16
↓↓↓↓↓↓↓↓↓↓↓↓

厉害啊，功能实现了，问题解决了

leon620

doul123 发表于 2016-2-22 09:01

多谢提点，问题已经搞定了。

leon620

解0人 发表于 2016-2-22 11:16
↓↓↓↓↓↓↓↓↓↓↓↓

能否在VBA代码中增加一些注释，看不懂啊

leon620

解0人 发表于 2016-2-22 11:16
↓↓↓↓↓↓↓↓↓↓↓↓

您编写的代码，我看不懂，现在想实现：4个文本框，光标切换，则图片跟着切换，不知道怎么编写VBA程序，您能否指点一下，谢谢。

解0人

↓↓↓↓↓↓↓↓↓↓↓↓

leon620

解0人 发表于 2016-3-1 10:10
↓↓↓↓↓↓↓↓↓↓↓↓

高手啊，太厉害了，多谢

anhzj

解0人 发表于 2016-2-22 11:16
↓↓↓↓↓↓↓↓↓↓↓↓

我要下载啊，怎么不对