导出图片Excel VBA

尝试从工作簿中select和导出所有图片时遇到问题。 我只想要照片。 我需要在工作簿的同一个文件夹中select并保存所有的“照片1”，“照片2”，“照片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 

Answer 1

这段代码是基于我在这里find的。 它经过了大量的修改和精简。 该代码将所有工作表中的工作簿中的所有图片以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 

Answer 2

一个简单的方法，如果你的Excel文件是一个开放的XML格式：

• 添加一个ZIP扩展名到您的文件名
• 浏览生成的ZIP包，然后查找\ xl \ media子文件夹
• 所有的embedded式图片都应该作为独立的图片文件放在那里

Answer 3

罗斯的方法效果很好，但使用图表部队的添加方法离开当前激活的工作表…你可能不想做的事情。

为了避免你可以使用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