CODEWITHSUNDEEP
imagevbaexcelexport
Ygor Yansz
Ygor Yansz

Reputation: 176

Export Pictures Excel VBA

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

Upvotes: 3

Views: 35386

Answers (3)

ProtoVB
ProtoVB

Reputation: 793

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

Upvotes: 5

IAmDranged
IAmDranged

Reputation: 3020

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

Upvotes: 4

Ross McConeghy
Ross McConeghy

Reputation: 874

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

Upvotes: 4

Related Questions