Excel 通过 Powerpoint 批量保存图像，.Shapes.SaveAs 不起作用

Question

我需要将 Excel 中嵌入的相同图像批量转换为原始分辨率。我在网上找到了此代码，但它不起作用，需要修改。

1. 它给出了一个错误.形状.另存为

2. 图像嵌入单元格，大小为原始大小的 9%。此代码可节省原始大小的 9%。我需要保存原始大小。

Sub SaveImages()
    'the location to save all the images
    Const destFolder = "C:\Users\user\Documents\test4\"

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("2PASTE")

    Dim ppt As Object, ps As Variant, slide As Variant

    Set ppt = CreateObject("PowerPoint.application")
    Set ps = ppt.presentations.Add
    Set slide = ps.slides.Add(1, 1)

    Dim shp As Shape, shpName
    For Each shp In ws.Shapes
        shpName = shp.TopLeftCell.Offset(0, 1) & ".png"
        shp.Copy
        With slide
            .Shapes.Paste
            'This is the point where the code breaks, when I try to save
            .Shapes.SaveAs Filename:=destFolder & shpName
            .Shapes(.Shapes.Count).Delete
        End With
    Next shp

    With ps
        .Saved = True
        .Close
    End With
    ppt.Quit
    Set ppt = Nothing
End Sub

谢谢你！！

Answer 1

我尝试了一下你的代码，让它在我的终端上运行起来。我认为问题在于你没有告诉它要保存哪张图片，你只是

Shapes.SaveAs

而不是说，

Shapes(1).SaveAs

然而，通过谷歌我发现了不同的图片保存语法......这是我的代码：

Sub SaveImages()
    'Save Images Here
    Const destFolder = " -- "
    'This Worksheet
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("2PASTE")
    
    Dim ppt As Object, ps As Variant, slide As Variant
    
    Set ppt = CreateObject("PowerPoint.application")
    Set ps = ppt.presentations.Add
    Set slide = ps.slides.Add(1, 1)

    Dim Shp As Shape, ShpName
    For Each Shp In ws.Shapes
        With Shp
            ShpName = .TopLeftCell.Offset(0, 1) & ".png"
            .Copy
        End With
        With slide
            .Shapes.Paste
            .Shapes(.Shapes.Count).Export destFolder & ShpName, ppShapeFormatPNG
            .Shapes(.Shapes.Count).Delete
        End With
    Next Shp

    With ps
        .Saved = True
        .Close
    End With
    ppt.Quit
    Set ppt = Nothing
End Sub

希望这对你有帮助。