我在尝试选择并导出工作簿中的所有图片时遇到问题。我只想要这些照片。我需要选择并将所有这些保存为:“Photo 1”,“Photo 2”,“photo 3”等,位于工作簿的同一文件夹中。
我已经尝试过这段代码:
Sub ExportPictures()
Dim n As Long, shCount As Long
shCount = ActiveSheet.Shapes.Count
If Not shCount > 1 Then Exit Sub
For n = 1 To shCount - 1
With ActiveSheet.Shapes(n)
If InStr(.Name, "Picture") > 0 Then
Call ActiveSheet.Shapes(n).CopyPicture(xlScreen, xlPicture)
Call SavePicture(ActiveSheet.Shapes(n), "C:\Users\DYNASTEST-01\Desktop\TEST.jpg")
End If
End With
Next
End Sub
答案 0 :(得分:4)
如果您的Excel文件是Open XML格式,这是一种简单的方法:
答案 1 :(得分:2)
此代码基于我找到的here。它经过了大量修改,并且有些精简。此代码将JPG格式的所有工作表中的所有图片保存到与工作簿相同的文件夹中。
它使用Chart对象的Export()方法来完成此任务。
Sub ExportAllPictures()
Dim MyChart As Chart
Dim n As Long, shCount As Long
Dim Sht As Worksheet
Dim pictureNumber As Integer
Application.ScreenUpdating = False
pictureNumber = 1
For Each Sht In ActiveWorkbook.Sheets
shCount = Sht.Shapes.Count
If Not shCount > 0 Then Exit Sub
For n = 1 To shCount
If InStr(Sht.Shapes(n).Name, "Picture") > 0 Then
'create chart as a canvas for saving this picture
Set MyChart = Charts.Add
MyChart.Name = "TemporaryPictureChart"
'move chart to the sheet where the picture is
Set MyChart = MyChart.Location(Where:=xlLocationAsObject, Name:=Sht.Name)
'resize chart to picture size
MyChart.ChartArea.Width = Sht.Shapes(n).Width
MyChart.ChartArea.Height = Sht.Shapes(n).Height
MyChart.Parent.Border.LineStyle = 0 'remove shape container border
'copy picture
Sht.Shapes(n).Copy
'paste picture into chart
MyChart.ChartArea.Select
MyChart.Paste
'save chart as jpg
MyChart.Export Filename:=Sht.Parent.Path & "\Picture-" & pictureNumber & ".jpg", FilterName:="jpg"
pictureNumber = pictureNumber + 1
'delete chart
Sht.Cells(1, 1).Activate
Sht.ChartObjects(Sht.ChartObjects.Count).Delete
End If
Next
Next Sht
Application.ScreenUpdating = True
End Sub
答案 2 :(得分:2)
Ross的方法运行良好,但使用图表强制的add方法离开当前激活的工作表...您可能不想这样做。
为了避免使用ChartObject
Public Sub AddChartObjects()
Dim chtObj As ChartObject
With ThisWorkbook.Worksheets("A")
.Activate
Set chtObj = .ChartObjects.Add(100, 30, 400, 250)
chtObj.Name = "TemporaryPictureChart"
'resize chart to picture size
chtObj.Width = .Shapes("TestPicture").Width
chtObj.Height = .Shapes("TestPicture").Height
ActiveSheet.Shapes.Range(Array("TestPicture")).Select
Selection.Copy
ActiveSheet.ChartObjects("TemporaryPictureChart").Activate
ActiveChart.Paste
ActiveChart.Export Filename:="C:\TestPicture.jpg", FilterName:="jpg"
chtObj.Delete
End With
End Sub