请选择 进入手机版 | 继续访问电脑版
查看: 208|回复: 0

[.NET开发] VBA粘贴Excel活动工作表中的每一嵌入式图表到一个新的幻灯片中并使用图表标题作为幻灯片标题

3万

主题

3万

帖子

10万

积分

管理员

Rank: 9Rank: 9Rank: 9

积分
100197
发表于 2015-11-23 17:52:02
这个程序复制 每个 嵌入式图表 活动工作表中 作为一个 图片 从一个 工作表 然后 粘贴到 一个新的幻灯片 结束时的 简报 嵌入式图表 是用来作为 新幻灯片的标题
  1. Sub ChartsAndTitlesToPresentation()
  2. ' Set a VBE reference to Microsoft PowerPoint Object Library
  3. Dim PPApp As PowerPoint.Application
  4. Dim PPPres As PowerPoint.Presentation
  5. Dim PPSlide As PowerPoint.Slide
  6. Dim PresentationFileName As Variant
  7. Dim SlideCount As Long
  8. Dim iCht As Integer
  9. Dim sTitle As String
  10. ' Reference existing instance of PowerPoint
  11. Set PPApp = GetObject(, "Powerpoint.Application")
  12. ' Reference active presentation
  13. Set PPPres = PPApp.ActivePresentation
  14. PPApp.ActiveWindow.ViewType = ppViewSlide
  15. For iCht = 1 To ActiveSheet.ChartObjects.Count
  16. With ActiveSheet.ChartObjects(iCht).Chart
  17. ' get chart title
  18. If .HasTitle Then
  19. sTitle = .ChartTitle.Text
  20. Else
  21. sTitle = ""
  22. End If
  23. ' remove title (or it will be redundant)
  24. .HasTitle = False
  25. ' copy chart as a picture
  26. .CopyPicture _
  27. Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
  28. ' restore title
  29. If Len(sTitle) > 0 Then
  30. .HasTitle = True
  31. .ChartTitle.Text = sTitle
  32. End If
  33. End With
  34. ' Add a new slide and paste in the chart
  35. SlideCount = PPPres.Slides.Count
  36. Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
  37. PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
  38. With PPSlide
  39. ' paste and select the chart picture
  40. .Shapes.Paste.Select
  41. ' align the chart
  42. PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
  43. PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
  44. .Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
  45. End With
  46. Next
  47. ' Clean up
  48. Set PPSlide = Nothing
  49. Set PPPres = Nothing
  50. Set PPApp = Nothing
  51. End Sub
复制代码


回复

使用道具 举报