问将所选图表作为图像导出到不同的.ppt幻灯片
EN

Stack Overflow用户

提问于 2017-07-03 15:20:43

回答 1查看 37关注 0票数 0

我想要做的是将一组图表作为图像导出到不同的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

vba

excel

powerpoint

回答 1

Stack Overflow用户

发布于 2017-07-03 16:38:24

脚本的powerpoint部分没有问题，可以正常工作。

当涉及到图表时，我建议不要处理形状，而是只使用ChartObjects集合- ChartObject是保存工作表上实际Chart的容器。

我不完全确定你所说的“选择”图表发送到ppt是什么意思，以及为什么你想要处理一个ShapeRange数组和形状组之类的东西，但是假设你在一张工作表上有一堆图表，你选择了一些图表，并希望将它们作为图片复制粘贴到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