导出图片 Excel VBA

Question

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

- Ygor Yansz

---

什么没有起作用？发生了什么事？ - Matt

工作簿的当前目录在这里。看起来你只是在覆盖同一张图片。你可以像这样做：Application.ActiveWorkbook.Path & "\Photo" & n & ".jpg" - Matt

Answer 1

罗斯的方法很有效，但是在使用图表的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

- ProtoVB

---

这是在尝试了许多其他建议后唯一有效的方法。谢谢。 - Awill

Answer 2

这段代码是基于我在这里找到的。它已经被大量修改并进行了一定程度的简化。此代码将把工作簿中所有工作表中的图片保存到与工作簿相同的文件夹中，以JPG格式保存。

它使用图表对象的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

- Ross McConeghy

---

@YgorYansz 很高兴能帮助您！请将此标记为答案。 - Ross McConeghy

将“Set MyChart = Charts.Add”改为“Set MyChart = Sht.Shapes.AddChart.Chart”更加规范。 - Jon Peltier

Answer 3

如果你的Excel文件是Open XML格式，有一种简单的方法：

• 在文件名后添加ZIP扩展名
• 浏览生成的ZIP包，并查找\xl\media子文件夹
• 所有嵌入的图片都应该作为独立的图像文件位于那里

- IAmDranged

---

闪亮的 :) 谢谢！ - pzelenovic

我喜欢你的方法... 有没有相关的VBA代码？ - Patrick Lepelletier