Я создаю базу данных Access, которая обновляет данные в презентации Powerpoint - в основном диаграммы со случайным битом текста. Весь код хранится в Access, проблема заключается во второй процедуре ниже.Обновите EmbeddedOLEObject Excel.Sheet.8 в Powerpoint 2007
Все работает нормально: я могу открыть шаблон презентации, получить данные из 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