在Powerpoint 2007中刷新EmbeddedOLEObject Excel.Sheet.8

我正在构build一个Access数据库，用于更新Powerpoint演示文稿中的数据 – 主要是图表，偶尔还有一些文本。 所有代码都存储在Access中，问题出在下面的第二个过程中。

一切工作正常：我可以打开演示文稿模板，从Access中获取数据到embedded图表背后的正确的工作表单元 – 然后我必须在用新数据更新之前手动编辑图表。

我有几个程序来做这个工作：

这第一个过程循环显示演示文稿中的每个幻灯片，并在达到某些形状时调用正确的过程：

Public Sub RefreshPowerPoint() Dim colPPT As Collection Dim oPPT As Object Dim oPresentation As Object Dim oSlide As Object Dim oShape As Object Set colPPT = New Collection Set colPPT = CreatePPT Set oPPT = colPPT(1) Set oPresentation = oPPT.Presentations.Open(CurrentProject.Path & "\QC Review - Template.pptx") For Each oSlide In oPresentation.slides For Each oShape In oSlide.Shapes If oShape.Type = 7 Then 'msoEmbeddedOLEObject If InStr(1, oShape.OLEFormat.progid, "MSGraph.Chart", vbTextCompare) > 0 Then 'Debug.Assert False ElseIf InStr(1, oShape.OLEFormat.progid, "Excel.Chart", vbTextCompare) > 0 Then 'Debug.Assert False ElseIf InStr(1, oShape.OLEFormat.progid, "Excel.Sheet", vbTextCompare) > 0 Then Select Case oSlide.SlideNumber Case 2 Refresh_TeamAccuracyMargins oShape Case 3 Case Else 'Do nothing End Select End If End If Next oShape Next oSlide End Sub 

下一个过程将Access查询中的数据复制到embedded的Excel工作表中。
该过程的最后几行显示了我试图用新数据更新实际图表 – 目前只有在手动点击“编辑”的时候，才会突然意识到有新的数据。

 Private Sub Refresh_TeamAccuracyMargins(sh As Object) Dim oWrkSht As Object Dim oWrkCht As Object Dim oLastCell As Object Dim rst As DAO.Recordset Dim x As Long Set oWrkSht = sh.OLEFormat.Object.Worksheets(1) Set oWrkCht = sh.OLEFormat.Object.Charts(1) Set oLastCell = LastCell(oWrkSht) With oWrkSht .Range(.Cells(2, 1), oLastCell).ClearContents End With Set rst = CurrentDb.OpenRecordset("SQL_REPORT_MonthlyAccuracyTrends") x = 1 With rst .MoveFirst Do While Not .EOF x = x + 1 oWrkSht.Cells(x, 1) = .Fields("sMonth") oWrkSht.Cells(x, 2) = .Fields("Accuracy") oWrkSht.Cells(x, 3) = .Fields("Inaccuracy") .MoveNext Loop .Close End With Set oLastCell = LastCell(oWrkSht) With oWrkSht oWrkCht.SetSourceData .Range(.Cells(1, 1), oLastCell), 2 oWrkCht.Activate 'Executes, appears to do nothing. oWrkCht.Refresh 'Executes, appears to do nothing. 'oWrkCht.Update 'Not supported. 'oWrkCht.Requery 'Not supported. 'oWrkCht.Repaint 'Not supported. 'oWrkCht.Parent.Refresh 'Not supported. End With Set rst = Nothing End Sub 

为了完整起见，这两个过程使用这些函数来创buildPowerpoint的实例并查找工作表中的最后一个单元格：

 '---------------------------------------------------------------------------------- ' Procedure : CreatePPT ' Date : 02/12/2015 ' Purpose : References or creates an instance of Powerpoint and returns the ' reference as the first part of a collection. ' The second part indicates whether Powerpoint was referenced or created. '----------------------------------------------------------------------------------- Public Function CreatePPT(Optional bVisible As Boolean = True) As Collection Dim oTmpPPT As Object Dim bIsOpen As Boolean Dim colTemp As Collection Set colTemp = New Collection '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Defer error trapping in case Powerpoint is not running. ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next Set oTmpPPT = GetObject(, "Powerpoint.Application") bIsOpen = True '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'If an error occurs then create an instance of Powerpoint. ' 'Reinstate error handling. ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If Err.Number <> 0 Then Err.Clear On Error GoTo ERROR_HANDLER Set oTmpPPT = CreateObject("Powerpoint.Application") bIsOpen = False End If oTmpPPT.Visible = bVisible colTemp.Add oTmpPPT colTemp.Add bIsOpen Set CreatePPT = colTemp Set colTemp = Nothing On Error GoTo 0 Exit Function ERROR_HANDLER: Select Case Err.Number Case Else MsgBox "Error " & Err.Number & vbCr & _ " (" & Err.Description & ") in procedure CreatePPT." Err.Clear End Select End Function '--------------------------------------------------------------------------------------- ' Procedure : LastCell ' Date : 26/11/2013 ' Purpose : Finds the last cell containing data or a formula within the given worksheet. ' If the Optional Col is passed it finds the last row for a specific column. '--------------------------------------------------------------------------------------- Public Function LastCell(wrkSht As Object, Optional col As Long = 0) As Object Dim lLastCol As Long, lLastRow As Long On Error Resume Next With wrkSht If col = 0 Then lLastCol = .Cells.Find("*", , , , 2, 2).Column lLastRow = .Cells.Find("*", , , , 1, 2).row Else lLastCol = .Cells.Find("*", , , , 2, 2).Column lLastRow = .Columns(col).Find("*", , , , 2, 2).row End If If lLastCol = 0 Then lLastCol = 1 If lLastRow = 0 Then lLastRow = 1 Set LastCell = wrkSht.Cells(lLastRow, lLastCol) End With On Error GoTo 0 End Function 

Answer 1

似乎激活正确的幻灯片并执行DoVerb更新图表。

所以，在我的第一个过程中，我通过参考Powerpoint应用程序来更新对刷新过程的调用：
Refresh_TeamAccuracyMargins oShape变成
Refresh_TeamAccuracyMargins oPPT, oShape

Private Sub Refresh_TeamAccuracyMargins(sh As Object)变成
Private Sub Refresh_TeamAccuracyMargins(oPPT As Object, sh As Object)

然后我更新图表源数据后激活幻灯片，所以这段代码：

 With oWrkSht oWrkCht.SetSourceData .Range(.Cells(1, 1), oLastCell), 2 End With 

变

 With oWrkSht oWrkCht.SetSourceData .Range(.Cells(1, 1), oLastCell), 2 oPPT.ActiveWindow.ViewType = 7 oPPT.ActiveWindow.View.GoToSlide 2 oPPT.ActiveWindow.ViewType = 1 sh.OleFormat.DoVerb (1) End With 

除了一些屏幕闪烁现在工作 – 任何想法如何摆脱屏幕闪烁？