导出图片 Excel VBA

Question

我在尝试从工作簿中选择和导出所有图片时遇到问题。我只想要图片。我需要选择并将它们全部保存为：“照片 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

此代码基于我找到的 here。它已经过大量修改并有所简化。此代码会将所有工作表中的工作簿中的所有图片以 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 文件是 Open XML 格式，一种简单的方法：

• 为您的文件名添加 ZIP 扩展名
• 探索生成的 ZIP 包，并查找 \xl\media 子文件夹
• 所有嵌入的图片都应该作为独立的图像文件放置在那里

Answer 3

Ross 的方法效果很好，但使用带有 Chart 的 add 方法会强制离开当前激活的工作表...您可能不想这样做。

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