VBA粘贴选定Excel嵌入式图表到当前PowerPoint幻灯片中

粘贴选定Excel嵌入式图表到当前PowerPoint幻灯片中    

01	Sub CopyChartsIntoPowerPoint()

02	''' COPY SELECTED EXCEL CHARTS INTO POWERPOINT

03	' Set a VBE reference to Microsoft PowerPoint Object Library

04

05	Dim pptApp As PowerPoint.Application

06	Dim iShapeIx As Integer, iShapeCt As Integer

07	Dim myShape As Shape, myChart As ChartObject

08	Dim bCopied As Boolean

09

10	Set pptApp = GetObject(, "PowerPoint.Application")

11

12	If ActiveChart Is Nothing Then

13	''' SELECTION IS NOT A SINGLE CHART

14	On Error Resume Next

15	iShapeCt = Selection.ShapeRange.count

16	If Err Then

17	MsgBox "Select charts and try again", vbCritical, "Nothing Selected"

18

Exit Sub

19

End If

20	On Error GoTo 0

21	For Each myShape In Selection.ShapeRange

22	''' IS SHAPE A CHART?

23	On Error Resume Next

24	Set myChart = ActiveSheet.ChartObjects(myShape.name)

25	If Not Err Then

26	bCopied = CopyChartToPowerPoint(pptApp, myChart)

27

End If

28	On Error GoTo 0

29

Next

30

Else

31	''' CHART ELEMENT OR SINGLE CHART IS SELECTED

32	Set myChart = ActiveChart.Parent

33	bCopied = CopyChartToPowerPoint(pptApp, myChart)

34

End If

35

36	Dim myPptShape As PowerPoint.Shape

37	Dim myScale As Single

38	Dim iShapesCt As Integer

39

40	''' BAIL OUT IF NO PICTURES ON SLIDE

41	On Error Resume Next

42	iShapesCt = pptApp.ActiveWindow.Selection.SlideRange.Shapes.count

43	If Err Then

44	MsgBox "There are no shapes on the active slide", vbCritical, "No Shapes"

45

Exit Sub

46

End If

47	On Error GoTo 0

48

49	''' ASK USER FOR SCALING FACTOR

50	myScale = InputBox(Prompt:="Enter a scaling factor for the shapes (percent)", _

51	Title:="Enter Scaling Percentage") / 100

52

53	''' LOOP THROUGH SHAPES AND RESCALE "PICTURES"

54	For Each myPptShape In pptApp.ActiveWindow.Selection.SlideRange.Shapes

55	If myPptShape.name Like "Picture*" Then

56	With myPptShape

57	.ScaleWidth myScale, msoTrue, msoScaleFromMiddle

58	.ScaleHeight myScale, msoTrue, msoScaleFromMiddle

59

End With

60

End If

61

Next

62

63	Set myChart = Nothing

64	Set myShape = Nothing

65	Set myPptShape = Nothing

66	Set pptApp = Nothing

67

End Sub

68

69	Function CopyChartToPowerPoint(oPPtApp As PowerPoint.Application, _

70	oChart As ChartObject)

71	CopyChartToPowerPoint = False

72

73	oChart.Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture, Size:=xlScreen

74	oPPtApp.ActiveWindow.View.Paste

75

76	CopyChartToPowerPoint = True

77	End Function