将所选图表作为图像导出到不同的.ppt幻灯片
将所选图表作为图像导出到不同的.ppt幻灯片
提问于 2017-07-03 23:20:43
我想要做的是将一组图表作为图像导出到不同的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回答 1
Stack Overflow用户
发布于 2017-07-04 00: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希望这能有所帮助。
注：如果你需要操作powerpoint幻灯片上的图片，你可以在PasteSpecial之后使用Set pastedPictureShape = pptSlide.Shapes(pptSlide.Shapes.Count)捕捉它
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/44889149
复制相关文章
相似问题
腾讯云开发者
