VBA调用excel中的图片

lxlaner

请问VBA窗体如何调用excel表格中的图片，
我的目的是将图片加载到excel中，根据要求在vba窗体中显示特定的图片

蓝桥玄霜

cName = ThisWorkbook.Path & "\Temp.jpg"
     Image1.Picture = LoadPicture(cName)

lxlaner

这个我知道，我的意思是调用已经加载进了EXCEL中的图片，这样别人在拷贝excel时会连图片一块拷贝

chijanzen

你好:
先將工作表中的圖片匯出為*.jpg檔，然後再使用LoadPicture方法載入Image 控件，最後再將該暫存檔刪除
做了一個範例，請參考

Image 控件調用excel工作表中的圖片

lxlaner

楼上的兄弟可否附一个文件上来，你的网址打不开

lxlaner

还有其他的办法吗？

chijanzen

原帖由 lxlaner 於 2008-11-22 23:25 發表
樓上的兄弟可否附一個文件上來，你的網址打不開

附件已上傳

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


[ 本帖最后由 chijanzen 于 2008-11-22 23:52 编辑 ]

lxlaner

感觉很复杂，为什么没有简单的方法呢

gogowind

的确比较复杂

2001927f

步骤1：在要插入批注的单元格上右击，选择“插入批注”命令，这时在该单元格右侧出现一个黄色背景的批注框。

　　步骤2：在该批注的单元格上右击，选择“编辑批注”命令，此时单元格处于批注编辑状态，光标置于批注方框内，将方框内的原有文字(“微软用户：”)删除。

　　步骤3：在批注边框上右击，选择“设置批注格式”命令，在弹出的对话框中选择“颜色和线条”标签，在“填充”区域的“色彩”下拉列表中点选“填充效果”。

　　步骤4：在弹出的“填充效果”对话框中选择“图片”标签，接着单击“选择图片”按钮，找到指定的图片后，一路“确定”下去，一份图文并茂的目录清单就打造成功了。

　　以后鼠标滑过批注单元格时，就会出现产品外观的预览效果。
不知道这个办法能不能解决你的问题！