简体   繁体   中英

storing an image to a cell from a form using vba in excel

I have a picturebox in a form in excel 2013. I am able to put image there from VBA. Now I want to put that image in a excel cell by clicking a button.

For this I have done the following code:

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

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

It gives me no error but displaying some weird numeric values in the cell...

Can anyone please help me with this situation.

i need to go to sleep, but i found this :

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

and then :

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

or this , works too

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

i will try this tomorrow...

EDIT : ok now i got it working, as follows inside the userform page code, and i name a button 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

and inside a standard module (would also work in userform code but like this its all purpose) :

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 : the parts i removed from the code are not working or make errors.

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM