I'm building an Access database which updates the data within a Powerpoint presentation - mainly charts, with the occasional bit of text. All code is stored in Access, the problem is in the second procedure below.
Everything is working fine: I can open the presentation template, get the data from Access into the correct worksheets cells behind the embedded chart - I then have to manually edit the chart before it updates with the new data though.
I have a few procedures to do the work:
This first procedure cycles through each slide in the presentation and calls the correct procedure when certain shapes are reached:
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
This next procedure copies the data from the Access query into the embedded Excel sheet.
The last few lines of the procedure show what I have tried to get the actual chart to update with the new data - at the moment it's only doing it if I manually click 'Edit' at which point it suddenly realises there's new data.
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
For completeness the two procedures use these functions to create an instance of Powerpoint and to find the last cell on the worksheet:
'----------------------------------------------------------------------------------
' 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
It seems that activating the correct slide and executing DoVerb updates the chart.
So, in my first procedure I update the call to the Refresh procedures with a reference to the Powerpoint application:
Refresh_TeamAccuracyMargins oShape becomes
Refresh_TeamAccuracyMargins oPPT, oShape
Private Sub Refresh_TeamAccuracyMargins(sh As Object) becomes
Private Sub Refresh_TeamAccuracyMargins(oPPT As Object, sh As Object)
I then activate the slide after updating the chart source data, so this block of code:
With oWrkSht
oWrkCht.SetSourceData .Range(.Cells(1, 1), oLastCell), 2
End With
becomes
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
Apart from some screen flickering it now works - any idea on how to get rid of the screen flickering?