问题:

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.

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

回答1:

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.

It uses the Export() Method of the Chart object to accomplish this.

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:

One easy approach if your excel file is an Open XML format:

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

回答3:

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.

In order to avoid that you could use 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

Export Pictures Excel VBA

问题:

回答1:

回答2:

回答3: