0

我有一个演示文稿，我想在演示文稿模式下连续循环并自动更新演示文稿中的图表。我发现您可以使用链接来执行此操作，但是一旦您关闭 .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

我有一个类模块clsAppEvents

Public WithEvents App As Application

Private Sub App_AfterDragDropOnSlide(ByVal Sld As slide, ByVal X As Single, ByVal Y As Single)
Debug.Print "App_AfterDragDropOnSlide"
End Sub

Private Sub App_AfterNewPresentation(ByVal Pres As Presentation)
Debug.Print "App_AfterNewPresentation"
End Sub

Private Sub App_AfterPresentationOpen(ByVal Pres As Presentation)
Debug.Print "App_AfterPresentationOpen"
End Sub

Private Sub App_AfterShapeSizeChange(ByVal shp As Shape)
Debug.Print "App_AfterShapeSizeChange"
End Sub

Private Sub App_ColorSchemeChanged(ByVal SldRange As SlideRange)
Debug.Print "App_ColorSchemeChanged"
End Sub

Private Sub App_NewPresentation(ByVal Pres As Presentation)
Debug.Print "App_NewPresentation"
End Sub

Private Sub App_PresentationBeforeClose(ByVal Pres As Presentation, Cancel As Boolean)
Debug.Print "App_PresentationBeforeClose"
End Sub

Private Sub App_PresentationBeforeSave(ByVal Pres As Presentation, Cancel As Boolean)
Debug.Print "App_PresentationBeforeSave"
End Sub

Private Sub App_PresentationClose(ByVal Pres As Presentation)
Debug.Print "App_PresentationClose"
End Sub

Private Sub App_PresentationCloseFinal(ByVal Pres As Presentation)
Debug.Print "App_PresentationCloseFinal"
End Sub

Private Sub App_PresentationNewSlide(ByVal Sld As slide)
Debug.Print "App_PresentationNewSlide"
End Sub

Private Sub App_PresentationOpen(ByVal Pres As Presentation)
Debug.Print "App_PresentationOpen"
End Sub

Private Sub App_PresentationPrint(ByVal Pres As Presentation)
Debug.Print "App_PresentationPrint"
End Sub

Private Sub App_PresentationSave(ByVal Pres As Presentation)
Debug.Print "App_PresentationSave"
End Sub

Private Sub App_PresentationSync(ByVal Pres As Presentation, ByVal SyncEventType As Office.MsoSyncEventType)
Debug.Print "App_PresentationSync"
End Sub

Private Sub App_ProtectedViewWindowActivate(ByVal ProtViewWindow As ProtectedViewWindow)
Debug.Print "App_ProtectedViewWindowActivate"
End Sub

Private Sub App_ProtectedViewWindowBeforeClose(ByVal ProtViewWindow As ProtectedViewWindow, ByVal ProtectedViewCloseReason As PpProtectedViewCloseReason, Cancel As Boolean)
Debug.Print "App_ProtectedViewWindowBeforeClose"
End Sub

Private Sub App_ProtectedViewWindowBeforeEdit(ByVal ProtViewWindow As ProtectedViewWindow, Cancel As Boolean)
Debug.Print "App_ProtectedViewWindowBeforeEdit"
End Sub

Private Sub App_ProtectedViewWindowDeactivate(ByVal ProtViewWindow As ProtectedViewWindow)
Debug.Print "App_ProtectedViewWindowDeactivate"
End Sub

Private Sub App_ProtectedViewWindowOpen(ByVal ProtViewWindow As ProtectedViewWindow)
Debug.Print "App_ProtectedViewWindowOpen"
End Sub

Private Sub App_SlideSelectionChanged(ByVal SldRange As SlideRange)
Debug.Print "App_SlideSelectionChanged"
End Sub

Private Sub App_SlideShowBegin(ByVal Wn As SlideShowWindow)
Debug.Print "App_SlideShowBegin"
End Sub

Private Sub App_SlideShowEnd(ByVal Pres As Presentation)
Debug.Print "App_SlideShowEnd"
End Sub

Private Sub App_SlideShowNextBuild(ByVal Wn As SlideShowWindow)
Debug.Print "App_SlideShowNextBuild"
End Sub

Private Sub App_SlideShowNextClick(ByVal Wn As SlideShowWindow, ByVal nEffect As Effect)
Debug.Print "App_SlideShowNextClick"
End Sub

Private Sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
Debug.Print "App_SlideShowNextSlide"
End Sub

Private Sub App_SlideShowOnNext(ByVal Wn As SlideShowWindow)
Debug.Print "App_SlideShowOnNext"
End Sub

Private Sub App_SlideShowOnPrevious(ByVal Wn As SlideShowWindow)
Debug.Print "App_SlideShowOnPrevious"
End Sub

Private Sub App_WindowActivate(ByVal Pres As Presentation, ByVal Wn As DocumentWindow)
Debug.Print "App_WindowActivate"
End Sub

Private Sub App_WindowBeforeDoubleClick(ByVal Sel As Selection, Cancel As Boolean)
Debug.Print "App_WindowBeforeDoubleClick"
End Sub

Private Sub App_WindowBeforeRightClick(ByVal Sel As Selection, Cancel As Boolean)
Debug.Print "App_WindowBeforeRightClick"
End Sub

Private Sub App_WindowDeactivate(ByVal Pres As Presentation, ByVal Wn As DocumentWindow)
Debug.Print "App_WindowDeactivate"
End Sub

Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
Debug.Print "App_WindowSelectionChange"
End Sub
4

1 回答 1

0

根据我以前的要求，我放弃了这样做的所有希望。为了解决拥有好图表的问题，我创建了一个 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 Coding 视频大喊，让我靠近。https://www.youtube.com/watch?v=DOaBtYMCCEM

于 2021-04-07T19:15:52.203 回答