Powerpoint プレゼンテーション内のデータを更新する Access データベースを構築しています。すべてのコードは Access に保存されます。問題は次の 2 番目の手順にあります。
すべて正常に動作しています。プレゼンテーション テンプレートを開き、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
完全を期すために、2 つの手順では、これらの関数を使用して 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