|
优点:能将图片按原有质量保存为文件
缺点:速度慢,图片格式不能自选
Sub savejpg()
Dim m, mc, shp As Shape
Dim nm, n&, mypath
Dim w, h, w1, h1, myhtm
Dim myxls As Workbook, thisbook, pic, pic1, psize
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & "\"
If Len(Dir(mypath & "图片", vbDirectory)) = 0 Then
MkDir mypath & "图片"
End If
Set thisbook = ThisWorkbook
Set myxls = Workbooks.Add
myhtm = "htm" & Format(Time, "hhmmss")
myxls.SaveAs Filename:=mypath & myhtm & ".htm", FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
For Each shp In thisbook.ActiveSheet.Shapes
If shp.type = 13 Then
w = shp.Width
h = shp.Height
shp.ScaleHeight 1, True
shp.ScaleWidth 1, True
w1 = shp.Width
h1 = shp.Height
n = n + 1
m = shp.TopLeftCell.Row
mc = thisbook.ActiveSheet.Cells(m, 2).Value
nm = mc & "-" & Format(n, "00")
'------------------------------------------------
shp.Copy
myxls.ActiveSheet.Paste
myxls.Save
shp.Width = w
shp.Height = h
psize = 0
pic1 = Dir(mypath & myhtm & ".files\image*.*")
Do While pic1 <> ""
If FileLen(mypath & myhtm & ".files\" & pic1) > psize Then
pic = pic1
psize = FileLen(mypath & myhtm & ".files\" & pic1)
End If
pic1 = Dir
Loop
On Error Resume Next
Name mypath & myhtm & ".files\" & pic As mypath & "图片\" & nm & "." & Split(pic, ".")(1)
On Error GoTo 0
myxls.ActiveSheet.Shapes(1).Delete
'----------------------------------------------------
End If
Next
myxls.Close 0
Kill mypath & myhtm & ".htm"
Kill mypath & myhtm & ".files\*.*"
RmDir mypath & myhtm & ".files"
Application.ScreenUpdating = True
MsgBox "The End"
End Sub
测试附件:
批量保存表格中的图片到文件夹2.part1.rar
(2 MB, 下载次数: 365)
批量保存表格中的图片到文件夹2.part2.rar
(1.16 MB, 下载次数: 331)
|
评分
-
3
查看全部评分
-
|