我正在构建一个 Access 数据库，用于更新 Powerpoint 演示文稿中的数据 - 主要是图表，偶尔会有一些文本。所有代码都存储在 Access 中，问题出在下面的第二个过程中。
一切正常：我可以打开演示模板，将数据从 Access 获取到嵌入图表后面的正确工作表单元格中 - 然后我必须手动编辑图表，然后才能使用新数据进行更新。
我有一些程序来完成这项工作：
第一个过程循环遍历演示文稿中的每张幻灯片，并在达到某些形状时调用正确的过程：
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 查询复制到嵌入的 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
为了完整起见，这两个过程使用这些函数来创建 Powerpoint 实例并找到工作表上的最后一个单元格：
'----------------------------------------------------------------------------------
' 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