Question

我要做的是将选择的图表导出到不同的PowerPoint幻灯片作为图像。当我尝试导出单个图表时，它可以工作，但选择多个图表并尝试再次导出它们不起作用。

我错过了什么？下面是我为解决我的问题而尝试的代码。

Sub SendTop2ChartsToPPT()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim pptShpRng As PowerPoint.ShapeRange
Dim lActiveSlideNo As Long
Dim ChtObj As ChartObject
Dim ChartSh As Worksheet
Dim FolderPath As String
Dim fName As String

Set ChartSh = Worksheets("Graphs")
FolderPath = ThisWorkbook.Path
fName = "Report Top2 (" & Format(Date, "yyyy-mmm") & ")"
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
On Error Resume Next
If pptApp Is Nothing Then
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Add
    Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
Else
    If pptApp.Presentations.Count > 0 Then
        Set pptPres = pptApp.ActivePresentation
        If pptPres.Slides.Count > 0 Then
            lActiveSlideNo = pptApp.ActiveWindow.View.Slide.SlideIndex
            Set pptSlide = pptPres.Slides(lActiveSlideNo)
        Else
            Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
        End If
    Else
        Set pptPres = pptApp.Presentations.Add
        Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
    End If
End If
ChartSh.Shapes.Range(Array("Top2SiteVisits", "Top2SiteShare")).Select
Set ChtObj = Selection.ShapeRange.Group
ChtObj.CopyPicture

    With pptSlide
        .Shapes.Paste
        Set pptShape = .Shapes(.Shapes.Count)
        Set pptShpRng = .Shapes.Range(pptShape.Name)
    End With

    With pptShpRng
        .Top = 0
        .Left = 0
        .Height = pptPres.PageSetup.SlideHeight
        .Width = pptPres.PageSetup.SlideWidth
    End With

    With pptPres
        .SaveAs FolderPath & "\" & fName & ".pptx"
        .Close
    End With

    pptApp.Quit
    ChtObj.ShapeRange.Ungroup
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

Answer 1

脚本的powerpoint部分很好，可以使用。

说到图表，我建议不要处理Shapes，而只是使用ChartObjects集合 - ChartObject是容纳实际Chart的容器工作表。

我不完全确定你的意思是“选择”图表发送到ppt以及为什么你想要处理ShapeRange数组并处理Shape组等等，但是让我们说你在一张纸上有一堆图表，你可以选择一些图表并希望将它们复制粘贴到powerpoint作为图片：以下内容就是这样，每张图表都有一张新幻灯片。

Sub SelectedChartsToPPTSlide()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim ChtObj As ChartObject

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add

For Each ChtObj In Selection 'Will error if your selection includes other shapes and such.
    Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
    ChtObj.Chart.CopyPicture
    pptSlide.Shapes.PasteSpecial
Next ChtObj

Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub

以同样的方式，您可以遍历工作表中的ChartObjects：

For each ChtObj in Worksheets("Graphs").ChartObjects
    If ChtObj.Chart.Name = "Some name here" Then
        'Do stuff with that chart
    End If
Next ChtObj

希望这有帮助。

N.b。如果您需要操纵powerpoint幻灯片上的图片，可以在Set pastedPictureShape = pptSlide.Shapes(pptSlide.Shapes.Count)

之后立即使用PasteSpecial抓取它

将指定的图表选择作为图像导出到不同的.ppt幻灯片

1 个答案: