Clever Geek Handbook

Excel VBA Image Export

I am having trouble trying to select and export all photos from a book. I need pictures. I need to select and save all of them as "Photo 1", "Photo 2", "Photo 3", etc. In the same book folder.

I've 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
+3


source to share


3 answers


This code is based on what I found here . It has been heavily modified and somewhat simplified. This code will save all images in the workbook from all sheets in the same folder as the workbook, in JPG format.

For this, the Export () method of the Chart object is used.



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


source


One simple approach if your excel file is open XML format:



  • add zip extension to your filename
  • examine the resulting ZIP package and find the \ xl \ media subfolder
  • all of your inline images should be located there as independent image files.
+4


source


Ross's method works well, but with the add method with Chart forces, exit the currently activated worksheet ... which you might not want to do.

To avoid this, you can 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
+2


source






More articles:


All Articles