在Excel中使用VBA將圖像從表單存儲到單元格中

Question

我在Excel 2013的表單中有一個圖片框。我可以從VBA放圖片。 現在，我想通過單擊按鈕將該圖像放在excel單元格中。

為此，我完成了以下代碼：

Sheets("Inventory").Activate
rowno = ActiveSheet.UsedRange.Rows.Count

    cellrange = "N" & Trim(Str(rowno))
    range(cellrange).Value = Image2.Picture

它沒有給我任何錯誤，但是在單元格中顯示了一些奇怪的數值。

任何人都可以在這種情況下幫助我。

Answer 1

我需要去睡覺，但是我發現了這一點：

SavePicture me.Image2.picture, FileNameString 'saves the picture controlform to disk

接着 ：

activesheet.pictures.insert (FileNameString) 'gets it back to activecell

或者這個也可以

activesheet.AddPicture(FileNameString, LinkToFileBoolean, SaveWithDocumentBoolean, LeftDouble, TopDouble, WidthDouble, HeightDouble)

我明天試試看...

編輯：好的，現在我可以正常工作了，在用戶窗體頁面代碼中如下所示，我將按鈕命名為CommandButton1：

Private Sub CommandButton1_Click()
Call UserForm_To_Range(Me.Image1, ThisWorkbook.Sheets(1).Cells(1, 1), true, "")  'ImageName , Range_to_paste , Stretch yes/no , path & name of temporary file (i think its a bmp because method 2 not working (?)) 
'in the previous line, setting the argument true to false will show the image at its original size
End Sub

並在標准模塊內（也可以在用戶形式的代碼中使用，但所有目的都是這樣）：

Option Explicit

Sub UserForm_To_Range(ByRef Img As IPictureDisp, Optional ByVal Rg As Range, Optional ByVal Stretch As Boolean = True, Optional ByVal Full_Path_Name As String) ', Optional ByVal Insert_Methode As Long = 1)
'If IsMissing(Rg) Then Set Rg = Selection
'If IsMissing(Full_Path_Name) Then Full_Path_Name = ThisWorkbook.Path
If Rg Is Nothing Then Set Rg = Selection
If Full_Path_Name = "" Then Full_Path_Name = ThisWorkbook.Path

If InStr(1, Full_Path_Name, ".") = 0 Then Full_Path_Name = Full_Path_Name & "\temp.bmp"
SavePicture Img, Full_Path_Name
Dim h$
h = Dir(Full_Path_Name) 'test if exists ; h is the file name without its path
If h <> "" Then
    Dim Sh As Worksheet
    Dim Pic As Shape
    Set Sh = Rg.Parent
    With Sh
        'Select Case Insert_Methode
        '    Case 1:
                If Stretch Then 'what i call stretch is fit to cell/range
                    Set Pic = .Shapes.AddPicture(Full_Path_Name, False, True, Rg.Left, Rg.Top, Rg.Width, Rg.Height)
                Else
                    Set Pic = .Shapes.AddPicture(Full_Path_Name, False, True, Rg.Left, Rg.Top, Imag.Width, Imag.Height)
            End If
                Kill (Full_Path_Name)
            'Case 2:
            '    Set Pic = .Pictures.Insert(Full_Path_Name)
            '    With Pic
            '        .Width = Rg.Width '75
            '        .Height = Rg.Height '100
            '        .Left = Rg.Left
            '        .Top = Rg.Top
            '    End With
        'End Select
        With Pic
            .LockAspectRatio = msoTrue
            If Stretch Then
                .Placement = xlMoveAndSize
            Else
                .Placement = xlMove
            End If
            .LockAspectRatio = msoTrue
            '.PrintObject = True
        End With
    End With
Else
    Beep
End If

Set Pic = Nothing
Set Rg = Nothing
Set Sh = Nothing
Set Img = Nothing

End Sub

PS：我從代碼中刪除的部分無法正常工作或出錯。