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

[.NET开发] VBA粘贴Excel Chart图表到当前PowerPoint幻灯片中(后期绑定)

3万

主题

3万

帖子

10万

积分

管理员

Rank: 9Rank: 9Rank: 9

积分
100197
发表于 2015-11-23 17:52:03
这个程序复制活跃的嵌入式图表作为一个图片从一个工作表,然后粘贴到积极的幻灯片演示文稿。这是相同的上述程序,但它使用(见早期与后期绑定)后期绑定;突出的变化,在绿色。在后期绑定变量的类型,具体参考的对象库必须取代通用对象变量和常量,必须更换的数字等值。我喜欢把简报等同于一个评论帮助文档的代码。
  1. Sub ChartToPresentation()
  2. ' Uses Late Binding to the PowerPoint Object Model
  3. ' No reference required to PowerPoint Object Library
  4. Dim PPApp As Object ' As PowerPoint.Application
  5. Dim PPPres As Object ' As PowerPoint.Presentation
  6. Dim PPSlide As Object ' As PowerPoint.Slide
  7. ' Make sure a chart is selected
  8. If ActiveChart Is Nothing Then
  9. MsgBox "Please select a chart and try again.", vbExclamation, _
  10. "No Chart Selected"
  11. Else
  12. ' Reference existing instance of PowerPoint
  13. Set PPApp = GetObject(, "Powerpoint.Application")
  14. ' Reference active presentation
  15. Set PPPres = PPApp.ActivePresentation
  16. PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
  17. ' Reference active slide
  18. Set PPSlide = PPPres.Slides _
  19. (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
  20. ' Copy chart as a picture
  21. ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
  22. Format:=xlPicture
  23. ' Paste chart
  24. PPSlide.Shapes.Paste.Select
  25. ' Align pasted chart
  26. PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
  27. PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
  28. ' Clean up
  29. Set PPSlide = Nothing
  30. Set PPPres = Nothing
  31. Set PPApp = Nothing
  32. End If
  33. End Sub
复制代码
  1. Option Explicit
  2. Private Sub RefreshRangeToSlide(PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, ByRef RefShape As PowerPoint.Shape, order As Integer, iStart As Integer, iEnd As Integer, jStart As Integer, jEnd As Integer, leftPosition As Single, topPosition As Single, widthSize As Single, heightSize As Single, AlternativeText As String)
  3. Dim PPSlide As PowerPoint.Slide
  4. 'Get specified the slide to add excel table
  5. Set PPSlide = PPPres.Slides(order)
  6. RefShape.AlternativeText = "useless"
  7. With Worksheets("Sheet1")
  8. .Range(.Cells(iStart, jStart), .Cells(iEnd, jEnd)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
  9. End With
  10. With PPApp.ActiveWindow
  11. .View.Paste
  12. With .Selection.ShapeRange
  13. .LockAspectRatio = msoFalse
  14. .Left = leftPosition
  15. .Top = topPosition
  16. .Width = widthSize
  17. .Height = heightSize
  18. .AlternativeText = AlternativeText
  19. End With
  20. End With
  21. End Sub
  22. Private Sub RefreshShapeToSlide(PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, ByRef RefShape As PowerPoint.Shape, order As Integer, ChartName As String, leftPosition As Single, topPosition As Single, weightSize As Single, heightSize As Single, AlternativeText As String)
  23. Dim PPSlide As PowerPoint.Slide
  24. Dim Shape_Row As Integer
  25. Dim Shape_Column As Integer
  26. Dim myChar As ChartObject
  27. 'Get specified the slide to add chart picture
  28. Set PPSlide = PPPres.Slides(order)
  29. RefShape.AlternativeText = "useless"
  30. With Worksheets("Sheet1")
  31. .Activate
  32. .ChartObjects(ChartName).Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  33. End With
  34. With PPApp.ActiveWindow
  35. .View.Paste
  36. With .Selection.ShapeRange
  37. .LockAspectRatio = msoFalse
  38. .Left = leftPosition
  39. .Top = topPosition
  40. .Width = weightSize
  41. .Height = heightSize
  42. .AlternativeText = AlternativeText
  43. End With
  44. End With
  45. End Sub
  46. Private Sub RefreshChartLabelToSlide(PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, ByRef RefShape As PowerPoint.Shape, order As Integer, leftPosition As Single, topPosition As Single, weightSize As Single, heightSize As Single, AlternativeText As String, ParamArray ShapeObjects() As Variant)
  47. Dim PPSlide As PowerPoint.Slide
  48. Dim Shape_Row As Integer
  49. Dim Shape_Column As Integer
  50. Dim myChar As ChartObject
  51. 'Get specified the slide to add chart picture
  52. Set PPSlide = PPPres.Slides(order)
  53. RefShape.AlternativeText = "useless"
  54. With Worksheets("Sheet1")
  55. .Activate
  56. .Shapes.Range(Array(ShapeObjects(0), ShapeObjects(1))).Select
  57. Selection.Copy
  58. End With
  59. With PPApp.ActiveWindow
  60. .View.PasteSpecial ppPastePNG
  61. With .Selection.ShapeRange
  62. .LockAspectRatio = msoFalse
  63. .Left = leftPosition
  64. .Top = topPosition
  65. .Width = weightSize
  66. .Height = heightSize
  67. .AlternativeText = AlternativeText
  68. End With
  69. End With
  70. End Sub
  71. Sub ExcelToNewpowerPoint()
  72. 'Sheet1.Shapes("Chart 1").AlternativeText = "ServiceData"
  73. Application.ScreenUpdating = False
  74. Dim fileSaveName
  75. Dim objFSO
  76. Dim FileName As String
  77. Dim HasRefreshed As Boolean
  78. Dim FilePath As String
  79. Dim Templae As Boolean
  80. Dim Country As String
  81. Dim City As String
  82. Dim PPApp As PowerPoint.Application
  83. Dim PPPres As PowerPoint.Presentation
  84. Dim curSld As PowerPoint.Slide
  85. Dim curShp As PowerPoint.Shape
  86. Dim Sldorder As Integer
  87. Dim leftPosition As Single, topPosition As Single, weightSize As Single, heightSize As Single
  88. Dim ServiceData As Boolean, Template As Boolean
  89. HasRefreshed = True
  90. With Worksheets("Sheet1")
  91. FileName = "A801" '.combobox1.Value & "-" & .combobox2.Value & "-" & .comboBox3.Value
  92. FilePath = ThisWorkbook.Path
  93. FilePath = FilePath & IIf(Right(FilePath, 1) <> "", "", "")
  94. fileSaveName = Application.GetSaveAsFilename(InitialFileName:="http://MyTeamSpace/" & Country & "/" & City & "/" & Replace(FileName, ".", "") & ".pptx", filefilter:="powerPoint Sildes (*.pptx), *.pptx")
  95. If fileSaveName <> False Then
  96. Set objFSO = CreateObject("Scripting.FileSystemObject")
  97. Set PPApp = CreateObject("PowerPoint.Application")
  98. With PPApp
  99. .Activate
  100. On Error GoTo Template
  101. Set PPPres = .Presentations.Open(FileName:=fileSaveName)
  102. If Template Then
  103. 'Template: Set PPPres = .Presentations.Open(FileName := "http://MyTeamSpace/Template.pptx")
  104. Template: Set PPPres = .Presentations.Open2007(FileName:="D:\Desktop\MondayWork.pptx")
  105. HasRefreshed = False
  106. End If
  107. Sldorder = 0
  108. .ActiveWindow.ViewType = ppViewNormal
  109. With PPPres
  110. For Each curSld In .Slides
  111. If curSld.Shapes.Count > 0 Then
  112. For Each curShp In curSld.Shapes
  113. Select Case curShp.AlternativeText
  114. Case "ServiceData"
  115. If Not ServiceData Then
  116. leftPosition = curShp.Left
  117. topPosition = curShp.Top
  118. weightSize = curShp.Width
  119. heightSize = curShp.Height
  120. 'RefreshShapeToSlide PPApp, PPPres, curShp, 3, "Chart 1", leftPosition, topPosition, weightSize, heightSize, "ServiceData"
  121. RefreshChartLabelToSlide PPApp, PPPres, curShp, 3, leftPosition, topPosition, weightSize, heightSize, "ServiceData", "Chart 1", "TextBox1"
  122. ServiceData = True
  123. End If
  124. End Select
  125. Next curShp
  126. For Each curShp In curSld.Shapes
  127. If curShp.AlternativeText = "useless" Then
  128. curShp.Delete
  129. End If
  130. Next curShp
  131. For Each curShp In curSld.Shapes
  132. If curShp.AlternativeText = "useless" Then
  133. curShp.Delete
  134. End If
  135. Next curShp
  136. For Each curShp In curSld.Shapes
  137. If curShp.AlternativeText = "useless" Then
  138. curShp.Delete
  139. End If
  140. Next curShp
  141. End If
  142. Next curSld
  143. Set objFSO = Nothing
  144. On Error GoTo errorlog:
  145. .SaveAs fileSaveName, ppSaveAsOpenXMLPresentation
  146. .Close
  147. Set PPPres = Nothing
  148. Application.Visible = True
  149. If HasRefreshed Then
  150. MsgBox "电子演讲稿更新完毕!"
  151. Else
  152. MsgBox "电子演讲稿生成完毕!"
  153. End If
  154. End With
  155. .Quit
  156. End With
  157. Set PPApp = Nothing
  158. End If
  159. End With
  160. Application.ScreenUpdating = True
  161. Exit Sub
  162. errorlog: MsgBox "请检查保存目录的访问权限!"
  163. End Sub
复制代码


回复

使用道具 举报