VBA 插入图片到指定单元格并保存图片为图片文件

'Upload File to the specific folder
Sub UploadImages(s$, c$)
's$      Buttom number
'c$      Specify a location to show image
'souf$   The local path of the image file
'des$    The dest path of the image file
'dt$     Get date for Named file

Dim fso As Object, souf$, des$
Dim fn As String
Dim n As Integer
On Error Resume Next
Set fso = CreateObject("Scripting.FilesyStemObject")
souf = Application.GetOpenFilename("All image files  (*.jpg,.png,.bmp,.gif),*.jpg,.png,.bmp,.gif")

dt = Format(Now, "yyyymmdd")
des = "D:\2\VBA\A3\Images\" & dt & "-" & s & ".jpg"
fso.CopyFile souf, des 'Copy file from the path Souf$ to des$
MsgBox "Upload Success!"
Set fso = Nothing
Call ShowImages(des, c)
End Sub
'show images
Sub ShowImages(fn$, val$)

 'fn$            The save path after uploaded
 'val$           Specify a location to show image ,the value of this variable from UploadImages function

    Dim oSP
    Dim oWK As Worksheet
    Dim sPath As String
    sPath = fn
    Set oWK = ActiveSheet
    'Insert Image
    Set oSP = oWK.Shapes.AddPicture(fn, msoCTrue, msoCTrue, 1, 1, 100, 100)
    'Resize Image
    With oSP

        .ScaleHeight 1, msoCTrue, msoScaleFromTopLeft
        .ScaleWidth 1, msoCTrue, msoScaleFromTopLeft
    End With

    'Fill image to cell
    With oSP
        .Left = oWK.Range(val).Left
        .Top = oWK.Range(val).Top
        .Height = oWK.Range(val).Height
        .Width = oWK.Range(val).Width
    End With

End Sub

'Buttons for upload image
Sub subm1()

    Call UploadImages("1", "L18:P23")
End Sub
Sub subm2()

    Call UploadImages("2", "L25:P30")
End Sub
Sub subm3()

    Call UploadImages("3", "Q25:V30")
End Sub
Sub subm4()

    Call UploadImages("4", "L41:P47")
End Sub
Sub Subm5()

    Call UploadImages("5", "L49:P55")
End Sub
Sub Subm6()

    Call UploadImages("6", "Q49:V55")
End Sub
Sub subm7()

    Call UploadImages("7", "X31:AC35")
End Sub
Sub subm8()

    Call UploadImages("8", "X37:AC40")
End Sub
Sub subm9()

Call UploadImages("9", "AD37:AH40")
End Sub