导出图片 Excel VBA
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/25333558/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Export Pictures Excel VBA
提问by Ygor Yansz
I'm having trouble trying to select and export all pictures from a workbook. I only want the pictures. I need to select and save all of them as:"Photo 1", "Photo 2", "photo 3", and so on, in the same folder of the workbook.
我在尝试从工作簿中选择和导出所有图片时遇到问题。我只想要图片。我需要在工作簿的同一文件夹中选择并保存所有这些：“照片 1”、“照片 2”、“照片 3”等。
I have already tried this code:
我已经试过这个代码：
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
回答by Ross McConeghy
This code is based on what I found here. It has been heavily modified and somewhat streamlined. This code will save all the pictures in a Workbook from all Worksheets to the same folder as the Workbook, in JPG format.
此代码基于我在此处找到的内容。它经过了大量修改，并在某种程度上进行了精简。此代码会将工作簿中所有工作表中的所有图片以 JPG 格式保存到与工作簿相同的文件夹中。
It uses the Export() Method of the Chart object to accomplish this.
它使用 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
回答by IAmDranged
One easy approach if your excel file is an Open XML format:
如果您的 excel 文件是 Open XML 格式，一种简单的方法是：
- add a ZIP extension to your filename
- explore the resulting ZIP package, and look for the \xl\media subfolder
- all your embedded pictures should be located there as independent image files
- 为您的文件名添加 ZIP 扩展名
- 探索生成的 ZIP 包，并查找 \xl\media 子文件夹
- 所有嵌入的图片都应该作为独立的图像文件位于那里
回答by ProtoVB
Ross's method works well but using the add method with Chart forces to leave the currently activated worksheet... which you may not want to do.
Ross 的方法效果很好，但是使用带有 Chart 的 add 方法会强制离开当前激活的工作表……您可能不想这样做。
In order to avoid that you could use ChartObject
为了避免你可以使用 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
