0
我正在構建一個Access數據庫，用於更新Powerpoint演示文稿中的數據 - 主要是圖表，偶爾還有一些文本。所有代碼都存儲在Access中，問題出在下面的第二個過程中。在Powerpoint 2007中刷新EmbeddedOLEObject Excel.Sheet.8
一切工作正常：我可以打開演示文稿模板，從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
爲完整的兩個程序使用這些函數來創建簡報的實例，並找到工作表上最後一個單元格：
'----------------------------------------------------------------------------------
' 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