Vba7 如何使PowerPoint图表自动更新？

我有一个演示，我想在演示模式下连续循环，并自动更新演示中的图表。我发现你可以通过链接来实现这一点，但一旦你关闭.ppt或.xls，链接就不再自动更新

为了解决这个问题，我从互联网上解析了一个宏，我认为这是可行的。我只是在创建触发事件时遇到问题。我发现这个网站为我指明了正确的方向（我想），我只是不知道该怎么办。"http://youpresent.co.uk/powerpoint-application-events-in-vba/“该网站有一个我下载的.pptm，其中包含以下大部分代码。任何帮助都将不胜感激

有人能解决这个问题吗？我很乐意接受任何建议

我目前的模块是：

    Option Explicit

Public oEH As New clsAppEVents

Sub slides()
    Dim pptSlide As slide
    Dim pptShape As Shape
    Dim SourceFile, FilePath As String
    Dim position As Integer
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim i As Integer
    
    i = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
    If i = 1 Then
    
        Set xlApp = New Excel.Application
            xlApp.Visible = False
            xlApp.DisplayAlerts = False
            
        For Each pptSlide In ActivePresentation.slides
            For Each pptShape In pptSlide.Shapes
    
                If pptShape.Type = 3 Then
                    SourceFile = pptShape.LinkFormat.SourceFullName
                    position = InStr(1, SourceFile, "!", vbTextCompare)
                    If position <> 0 Then
                        SourceFile = Left(SourceFile, position - 1)
                    End If
                    Set xlWB = xlApp.Workbooks.Open(SourceFile, True, True)
                        pptShape.LinkFormat.Update
                    xlWB.Close
                    Set xlWB = Nothing
                    
                End If
            Next
        Next
    End If
End Sub
Private Sub App_SlideShowNextClick(ByVal Wn As SlideShowWindow, ByVal nEffect As Effect)
    Set oEH.App = Application
    Call slides
End Sub

---

基于我以前的要求，我放弃了做这件事的所有希望。为了解决好图表的问题，我创建了一个Excel宏来创建一个新的PowerPoint演示文稿，并在保持源格式的同时将所有我想要的图表粘贴到其中。这会导致问题，因为必须使用

ExecuteMso

。下面是代码

Sub rtnPasteCharts()
    'declare ppt object vars
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim SldIndex As Integer
    'declare excel object vars
    Dim chrt As ChartObject
    'create a new instance of ppt
    Set PPTApp = New PowerPoint.Application
        PPTApp.Visible = True
    'creates a new presentation within the application
    Set PPTPres = PPTApp.Presentations.Add
    'create an index handler for slide creation
    SldIndex = 1
    'loop thru each chart objects on activesheet
    LastRow = Sheet6.Cells(Sheet6.Rows.Count, "R").End(xlUp).Row
    For Each chrt In ActiveSheet.ChartObjects
        For i = 2 To LastRow
            chrtTitle = Sheet6.Cells(i, 18).Text
            If chrt.Chart.ChartTitle.Text = chrtTitle Then
                Application.CutCopyMode = True
                chrt.Copy
                'creates a new slide
                Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
                'sets the slideshow transition timings
                With PPTPres.Slides(SldIndex).SlideShowTransition
                    .AdvanceOnClick = msoTrue
                    .AdvanceOnTime = msoTrue
                    .AdvanceTime = 30
                End With
                PPTSlide.Select
               'Creates a pause between selecting and pasting
                For j = 1 To 5000: DoEvents: Next
                PPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"
                PPTApp.CommandBars.ReleaseFocus
                SldIndex = SldIndex + 1
            End If
        Next i
    Next
End Sub

对Sigma编码视频大声呼喊，让我靠近

Sub rtnPasteCharts()
    'declare ppt object vars
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim SldIndex As Integer
    'declare excel object vars
    Dim chrt As ChartObject
    'create a new instance of ppt
    Set PPTApp = New PowerPoint.Application
        PPTApp.Visible = True
    'creates a new presentation within the application
    Set PPTPres = PPTApp.Presentations.Add
    'create an index handler for slide creation
    SldIndex = 1
    'loop thru each chart objects on activesheet
    LastRow = Sheet6.Cells(Sheet6.Rows.Count, "R").End(xlUp).Row
    For Each chrt In ActiveSheet.ChartObjects
        For i = 2 To LastRow
            chrtTitle = Sheet6.Cells(i, 18).Text
            If chrt.Chart.ChartTitle.Text = chrtTitle Then
                Application.CutCopyMode = True
                chrt.Copy
                'creates a new slide
                Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
                'sets the slideshow transition timings
                With PPTPres.Slides(SldIndex).SlideShowTransition
                    .AdvanceOnClick = msoTrue
                    .AdvanceOnTime = msoTrue
                    .AdvanceTime = 30
                End With
                PPTSlide.Select
               'Creates a pause between selecting and pasting
                For j = 1 To 5000: DoEvents: Next
                PPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"
                PPTApp.CommandBars.ReleaseFocus
                SldIndex = SldIndex + 1
            End If
        Next i
    Next
End Sub