VBA - Resizing a picture in excel-CodePudding

The code bellow paste the picture from my form into an activecell. But, how can I Resize the picture before past into excel?

Private Sub CommandButton1_Click()
 TransferToSheet Me.Image1, Plan2, 350
End Sub

Private Sub TransferToSheet(picControl, sht As Worksheet, picWidth As Long)
Const TemporaryFolder = 2
Dim fso, p

Set fso = CreateObject("scripting.filesystemobject")
p = fso.GetSpecialFolder(TemporaryFolder).Path & "\" & fso.gettempname
SavePicture picControl.Picture, p

With picControl.Picture.Insert(p)
.ShapeRange.LockAspectRatio = msoTrue
.Width = picWidth
End With
   
fso.deletefile p
Unload Me

End Sub

CodePudding user response：

Okay - I modified previous answer to handle fact that picture is actually a Shape - and you resize by using ShapeRange of the image.

Private Sub CommandButton1_Click()
    TransferToSheet Image1, Worksheets("Sheet1"), 350
End Sub


Private Sub TransferToSheet(picControl, sht As Worksheet, picWidth As Long)
    Const TemporaryFolder = 2
    Dim fso, p

    Set fso = CreateObject("Scripting.FileSystemObject")
    p = fso.GetSpecialFolder(TemporaryFolder).Path & "\" & fso.gettempname
    SavePicture picControl.Picture, p ' save to temp file
        
    ' Insert temp file inot new image
    With sht.Pictures.Insert(p)
        ' Resize
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = picWidth
        End With
    End With
    
    ' Delete Temp File
    fso.DeleteFile p
End Sub