在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：我从代码中删除的部分无法正常工作或出错。