VBA粘贴Excel Chart图表到当前PowerPoint幻灯片中（后期绑定）

VBA粘贴Excel Chart图表到当前PowerPoint幻灯片中（后期绑定）

章毅明 发布于 2012年01月26日 20时, 0评/539阅

分享到 

新浪微博腾讯微博

收藏 +1

踩 顶 0

这个程序复制活跃的嵌入式图表作为一个图片从一个工作表，然后粘贴到积极的幻灯片演示文稿。这是相同的上述程序，但它使用（见早期与后期绑定）后期绑定；突出的变化，在绿色。在后期绑定变量的类型，具体参考的对象库必须取代通用对象变量和常量，必须更换的数字等值。我喜欢把简报等同于一个评论帮助文档的代码。

标签： <无>

代码片段(2) [全屏查看所有代码]

1. [代码]粘贴Excel Chart图表到当前PowerPoint幻灯片中（后期绑定）     跳至 [1] [2] [全屏预览]

01	Sub ChartToPresentation()

02	' Uses Late Binding to the PowerPoint Object Model

03	' No reference required to PowerPoint Object Library

04

05	Dim PPApp As Object ' As PowerPoint.Application

06	Dim PPPres As Object ' As PowerPoint.Presentation

07	Dim PPSlide As Object ' As PowerPoint.Slide

08

09	' Make sure a chart is selected

10	If ActiveChart Is Nothing Then

11	MsgBox "Please select a chart and try again.", vbExclamation, _

12	"No Chart Selected"

13

Else

14	' Reference existing instance of PowerPoint

15	Set PPApp = GetObject(, "Powerpoint.Application")

16	' Reference active presentation

17	Set PPPres = PPApp.ActivePresentation

18	PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide

19	' Reference active slide

20	Set PPSlide = PPPres.Slides _

21	(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

22

23	' Copy chart as a picture

24	ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _

25	Format:=xlPicture

26

27	' Paste chart

28	PPSlide.Shapes.Paste.Select

29

30	' Align pasted chart

31	PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True

32	PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

33

34	' Clean up

35	Set PPSlide = Nothing

36	Set PPPres = Nothing

37	Set PPApp = Nothing

38

End If

39

40

End Sub

2. [代码]完整代码     跳至 [1] [2] [全屏预览]

001	Option Explicit

002

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)

003	Dim PPSlide As PowerPoint.Slide

004	'Get specified the slide to add excel table

005	Set PPSlide = PPPres.Slides(order)

006	RefShape.AlternativeText = "useless"

007	With Worksheets("Sheet1")

008	.Range(.Cells(iStart, jStart), .Cells(iEnd, jEnd)).CopyPicture Appearance:=xlScreen, Format:=xlPicture

009

End With

010	With PPApp.ActiveWindow

011	.View.Paste

012	With .Selection.ShapeRange

013	.LockAspectRatio = msoFalse

014	.Left = leftPosition

015	.Top = topPosition

016	.Width = widthSize

017	.Height = heightSize

018	.AlternativeText = AlternativeText

019

End With

020

End With

021

End Sub

022

023	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)

024	Dim PPSlide As PowerPoint.Slide

025	Dim Shape_Row As Integer

026	Dim Shape_Column As Integer

027	Dim myChar As ChartObject

028	'Get specified the slide to add chart picture

029	Set PPSlide = PPPres.Slides(order)

030	RefShape.AlternativeText = "useless"

031	With Worksheets("Sheet1")

032

.Activate

033	.ChartObjects(ChartName).Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture

034

End With

035	With PPApp.ActiveWindow

036	.View.Paste

037	With .Selection.ShapeRange

038	.LockAspectRatio = msoFalse

039	.Left = leftPosition

040	.Top = topPosition

041	.Width = weightSize

042	.Height = heightSize

043	.AlternativeText = AlternativeText

044

End With

045

End With

046

End Sub

047

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)

048	Dim PPSlide As PowerPoint.Slide

049	Dim Shape_Row As Integer

050	Dim Shape_Column As Integer

051	Dim myChar As ChartObject

052	'Get specified the slide to add chart picture

053	Set PPSlide = PPPres.Slides(order)

054	RefShape.AlternativeText = "useless"

055	With Worksheets("Sheet1")

056

.Activate

057	.Shapes.Range(Array(ShapeObjects(0), ShapeObjects(1))).Select

058	Selection.Copy

059

End With

060	With PPApp.ActiveWindow

061	.View.PasteSpecial ppPastePNG

062	With .Selection.ShapeRange

063	.LockAspectRatio = msoFalse

064	.Left = leftPosition

065	.Top = topPosition

066	.Width = weightSize

067	.Height = heightSize

068	.AlternativeText = AlternativeText

069

End With

070

End With

071

End Sub

072

073	Sub ExcelToNewpowerPoint()

074	'Sheet1.Shapes("Chart 1").AlternativeText = "ServiceData"

075	Application.ScreenUpdating = False

076	Dim fileSaveName

077	Dim objFSO

078	Dim FileName As String

079	Dim HasRefreshed As Boolean

080	Dim FilePath As String

081	Dim Templae As Boolean

082	Dim Country As String

083	Dim City As String

084	Dim PPApp As PowerPoint.Application

085	Dim PPPres As PowerPoint.Presentation

086	Dim curSld As PowerPoint.Slide

087	Dim curShp As PowerPoint.Shape

088	Dim Sldorder As Integer

089	Dim leftPosition As Single, topPosition As Single, weightSize As Single, heightSize As Single

090	Dim ServiceData As Boolean, Template As Boolean

091	HasRefreshed = True

092	With Worksheets("Sheet1")

093	FileName = "A801" '.combobox1.Value & "-" & .combobox2.Value & "-" & .comboBox3.Value

094	FilePath = ThisWorkbook.Path

095	FilePath = FilePath & IIf(Right(FilePath, 1) <> "\", "\", "")

096	fileSaveName = Application.GetSaveAsFilename(InitialFileName:="http://MyTeamSpace/" & Country & "/" & City & "/" & Replace(FileName, ".", "") & ".pptx", filefilter:="powerPoint Sildes (*.pptx), *.pptx")

097	If fileSaveName <> False Then

098	Set objFSO = CreateObject("Scripting.FileSystemObject")

099	Set PPApp = CreateObject("PowerPoint.Application")

100	With PPApp

101

.Activate

102	On Error GoTo Template

103	Set PPPres = .Presentations.Open(FileName:=fileSaveName)

104	If Template Then

105	'Template:             Set PPPres = .Presentations.Open(FileName := "http://MyTeamSpace/Template.pptx")

106	Template:             Set PPPres = .Presentations.Open2007(FileName:="D:\Desktop\MondayWork.pptx")

107	HasRefreshed = False

108

End If

109	Sldorder = 0

110	.ActiveWindow.ViewType = ppViewNormal

111	With PPPres

112	For Each curSld In .Slides

113	If curSld.Shapes.Count > 0 Then

114	For Each curShp In curSld.Shapes

115	Select Case curShp.AlternativeText

116	Case "ServiceData"

117	If Not ServiceData Then

118	leftPosition = curShp.Left

119	topPosition = curShp.Top

120	weightSize = curShp.Width

121	heightSize = curShp.Height

122	'RefreshShapeToSlide PPApp, PPPres, curShp, 3, "Chart 1", leftPosition, topPosition, weightSize, heightSize, "ServiceData"

123	RefreshChartLabelToSlide PPApp, PPPres, curShp, 3, leftPosition, topPosition, weightSize, heightSize, "ServiceData", "Chart 1", "TextBox1"

124	ServiceData = True

125

End If

126	End Select

127	Next curShp

128	For Each curShp In curSld.Shapes

129	If curShp.AlternativeText = "useless" Then

130	curShp.Delete

131

End If

132	Next curShp

133	For Each curShp In curSld.Shapes

134	If curShp.AlternativeText = "useless" Then

135	curShp.Delete

136

End If

137	Next curShp

138	For Each curShp In curSld.Shapes

139	If curShp.AlternativeText = "useless" Then

140	curShp.Delete

141

End If

142	Next curShp

143

End If

144	Next curSld

145	Set objFSO = Nothing

146	On Error GoTo errorlog:

147	.SaveAs fileSaveName, ppSaveAsOpenXMLPresentation

148

.Close

149	Set PPPres = Nothing

150	Application.Visible = True

151	If HasRefreshed Then

152	MsgBox "电子演讲稿更新完毕！"

153

Else

154	MsgBox "电子演讲稿生成完毕！"

155

End If

156

End With

157

.Quit

158

End With

159	Set PPApp = Nothing

160

End If

161

End With

162	Application.ScreenUpdating = True

163

Exit Sub

164	errorlog: MsgBox "请检查保存目录的访问权限！"

165

End Sub