最近自告奋勇给果子写个更新PPT图表的VBA，遇到的问题没想到是如此的麻烦，居然用掉我一周的时间～～

吐槽下微软...VBA复制ChartObjects到Powerpoint中居然是链接型的(linked)，没有嵌入式(embeded)模式可以选。

区别：link型ChartObjects可以实现数据的同步更新，但缺点是别人想打开ChartObject进行编辑时，如果没有Excel的源文件，并修复链接，那么这个图表是不可编辑的。

      embeded型ChartObjects我个人理解为一个OLEObject，它实现了复制OLE对象的原始数据到Office组件中(比如Word or PowerPoint)

很遗憾的是，Powerpoint 2010默认VBA函数中并不能实现embeded型数据图表的直接插入。经过上百次调试，最终找到了一条曲线救国的道路。

VBA没怎么玩，所以写的比较罗嗦。

基本思想：word 通过PasteAndFormart可以实现wtChart型图表插入，它是嵌入型，因此通过word作为跳板，就可以实现excel向ppt中插入嵌入型图表。

虽然想法很简单，但是实现起来却是麻烦重重，经过调试发现，wdChart在剪切板中存活着一个OLEObject型Chart时，word可以很顺利的粘贴chart，但是如果没有，那么就会报错，并锁定剪切板内数据格式，但此时剪切板中已经存在了这个chart的数据，如果继续下一步那么代码还是可以执行的。

因此，调用VBA中 on error 语句，同时通过直接paste的形式，刷新剪切板数据格式，那么此时就可以粘贴chart了。这里仅仅是个人看法，不一定准确，Maybe有更好的解决方法。

在退出跳板Word时，软件会提示剪切板中有大量数据，我勒个去，还搞～～～

因此，简单的想法就是刷新剪切板，刷新剪切板需要调用DataObject型，这个在word里面是可以实现的，但是在Excel环境下，不引用DataObject型库，那么电脑会罢工的！

而DataObject 又不是Word自带库，我×××，找来找去原来它是Microsoft Forms 2.0 Object library。但是默认引用中是找不到这个库的，我又×××。因此需要去搜索电脑中FM20.DLL，然后添加引用时，流览到该文件上面，这样就O了～～

现存代码有个问题在于Word必须可见，如果隐藏的话，会提示Word停止响应...

这个问题再尝试指定新Template时，有时可以解决，但是我×××，没摸索出规律。

其他的可以实现后台执行。

最终引用为：

附代码，引用代码请标注作者：

Sub cpChart2ppt()

'An Excel VBA Sub precedure for insert an Embeded Chart to PPT
'
' CopyRight (c)  2013     maxiao at Shanghai University

'                                           mxio@qq.com

'
'               http://blog.sina.com.cn/mxio
'
'                                                       mxio
'                                                 2013.05.20

Dim ppApp As PowerPoint.Application
Dim wdApp As Word.Application
Dim ppPres As Presentation
Dim wdDoc As Document
Dim xlWb As Workbook

Dim ncht As Integer
Dim nshp As Integer

On Error Resume Next
'Check whether Powerpoint is running
Set ppApp = GetObject(, "powerpoint.application")
If ppApp Is Nothing Then
    Set ppApp = CreateObject("powerpoint.application")
    'for automation to work, powerpoint must be visible
    ppApp.Visible = False
End If
On Error GoTo 0

On Error Resume Next
'Check whether word is running
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
    Set wdApp = CreateObject("Word.Application")
    'for automation to work, powerpoint must be visible
    wdApp.Visible = True
End If
On Error GoTo 0

Set xlWb = Workbooks.Open("D:\test.xlsx")
Set wdDoc = wdApp.Documents.Add(Visible:=False)

Set ppPres = ppApp.Presentations.Open("D:\test.pptx", WithWindow:=False)

xlWb.ActiveSheet.ChartObjects(1).Chart.ChartArea.Copy

With wdApp
    On Error Resume Next
    .Selection.PasteAndFormat wdChart
    If Err.Number <> 0 Then
    .Selection.Paste
    ncht = .ActiveDocument.InlineShapes.Count
    .Selection.PasteAndFormat wdChart
    .ActiveDocument.InlineShapes(ncht).Delete
    .ActiveDocument.InlineShapes(ncht).Chart.Copy
    Else
    ncht = .ActiveDocument.InlineShapes.Count
    .ActiveDocument.InlineShapes(ncht).Chart.Copy
    End If
End With
   
With ppApp
    With ppPres.Slides(1)
        .Shapes.Paste
        nshp = .Shapes.Count
            With .Shapes(nshp)
                .Top = 30
                .Left = 80
            End With
    End With
   
ppPres.Save
ppPres.Close
End With

   
'Quit

With wdApp
    Dim CLData As New DataObject
    CLData.SetText ""
    CLData.PutInClipboard
End With

wdDoc.Close savechanges:=False

ppApp.Quit
wdApp.Quit

Application.CutCopyMode = False
Application.DisplayAlerts = False
xlWb.Close savechanges:=False

'Clean up
Set ppPres = Nothing
Set ppApp = Nothing
Set wdApp = Nothing

End Sub

mxio

2013.5.20