vba单元格图片上传到mysql,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

标签：VBA,End,Sub,oWK,UploadImages,image,单元格,Call,图片

来源： https://www.cnblogs.com/luoye00/p/10496271.html