0
Excel 2010からPowerpoint Graph 2010を更新したいと考えています。 コードはオブジェクトを検索して、その名前の範囲をPowerPointで似ていると判断してグラフに変更を適用します。グラフ形式は同じでなければならず、データを更新する必要があります。Excel 2010からPowerpoint Graph 2010を更新する
コードは次のとおりです。コードを更新することはできません。
Option Explicit
Private Const NAMED_RANGE_PREFIX = "Export_"
Private Const NAMED_RANGE_PREFIX_TEXT = "ExportText"
Private m_sLog As String
Private Sub CommandButton1_Click()
On Error GoTo Catch
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim mgrChart As Chart
Dim mgrDatasheet As Graph.DataSheet
Dim rngData As Excel.Range
Dim iRow As Long, iCol As Long
Dim sTag As String
Dim nFound As Long, nUpdated As Long
Dim nFoundText As Long, nUpdatedText As Long
Dim i As Integer
Dim fLog As frmLog
Dim Box1Status As VbMsgBoxResult
m_sLog = ""
'Prompt to Export
Box1Status = MsgBox("Export and Save to Powerpoint Template?" & Chr(13) & "Reminder: Please use a clean template for export and be sure to back up the template beforehand. " & Chr(13) & Chr(13) & "PLEASE SAVE ANY OTHER OPEN POWERPOINT DOCUMENTS AS ALL UNSAVED WORK WILL BE LOST!", vbQuestion + vbYesNo, "Confirm Export")
If Box1Status = vbNo Then Exit Sub
i = 1
UpdateStatus "Opening Powerpoint presentation '" & Range("fileloc")
Set pptApp = New PowerPoint.Application
pptApp.Activate
Set pptPresentation = pptApp.Presentations.Open(Range("fileloc"))
pptApp.WindowState = ppWindowMinimized
'Looks for (tagged) charts to update
UpdateStatus "Searching presentation for charts..."
For Each pptSlide In pptPresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoEmbeddedOLEObject Then
If TypeOf pptShape.OLEFormat.Object Is Graph.Chart Then
nFound = nFound + 1
Set mgrChart = pptShape.OLEFormat.Object
Set mgrChart = pptShape.Chart
Set mgrDatasheet = mgrChart.Application.DataSheet
With mgrDatasheet
sTag = .Cells(1, 1)
If Left(sTag, 6) = "Export" Then UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with tag '" & sTag & "'. Searching Excel workbook for same tag..."
Set rngData = RangeForChart(sTag)
If rngData Is Nothing Then
' This chart has no data in this Excel workbook
If Left(sTag, 6) <> "Export" Then
UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with no tag, skipping"
Else
UpdateStatus "'" & sTag & "' does not exist in workbook, skipping."
End If
Else
' Update the PowerPoint chart with the Excel data
UpdateStatus "Found '" & sTag & "' at named range '" & rngData.Name & "'. Updating presentation..."
.Cells.ClearContents
For iRow = 0 To rngData.Rows.Count - 1
For iCol = 0 To rngData.Columns.Count - 1
.Cells(iRow + 1, iCol + 1) = rngData.Cells(iRow + 1, iCol + 1)
Next iCol
Next iRow
.Application.Update
UpdateStatus "Chart with tag '" & sTag & "' updated."
nUpdated = nUpdated + 1
End If
End With
Set mgrDatasheet = Nothing
mgrChart.Application.Quit
Set mgrChart = Nothing
End If
'End If
Next pptShape
i = i + 1
Next pptSlide
UpdateStatus "Finished searching presentation. Closing PowerPoint."
pptPresentation.Save
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
UpdateStatus "Done. " & nFound & " charts found and " & nUpdated & " charts updated. " & nFoundText & " text boxes found and " & nUpdatedText & " text boxes updated."
Set fLog = New frmLog
fLog.Caption = "Update of Powerpoint Template Complete"
fLog.txtLog.Text = m_sLog
fLog.Show
Unload fLog
Set fLog = Nothing
Exit Sub
Catch:
MsgBox "An unexpected error occurred while updating: " & Err.Number & " " & Err.Description, vbCritical
ForceCleanup mgrChart, mgrDatasheet, pptPresentation, pptApp
End Sub
Private Property Get RangeForChart(sTag As String) As Range
Dim sChartTag As String
Dim iUpdate As Long
Dim NameList As Range
'Dim nRow As Range
Set NameList = Range("Name_List")
If Left(sTag, 6) <> "Export" Then Exit Property
'For Each nRow In NameList.Rows
Do While sChartTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "Export_", which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sChartTag = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange.Cells(1, 1)
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
'Next nRow
Set RangeForChart = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange
End Property
Private Property Get RangeForText(sTag As String) As Range
Dim sTextTag As String
Dim iUpdate As Long
If Left(sTag, 10) <> "ExportText" Then Exit Property
Do While sTextTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "ExportText" & iUpdate, which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sTextTag = NAMED_RANGE_PREFIX_TEXT & iUpdate
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
Set RangeForText = ActiveWorkbook.Names(NAMED_RANGE_PREFIX_TEXT & iUpdate).RefersToRange
End Property
Private Sub UpdateStatus(sMessage As String)
m_sLog = m_sLog & Now() & ": " & sMessage & vbNewLine
Application.StatusBar = Now() & ": " & sMessage
DoEvents
End Sub
Private Sub ForceCleanup(mgrChart As Graph.Chart, mgrDatasheet As Graph.DataSheet, pptPresentation As PowerPoint.Presentation, pptApp As PowerPoint.Application)
On Error Resume Next
mgrChart.Application.Quit
Set mgrChart = Nothing
mgrDatasheet.Application.Quit
Set mgrDatasheet = Nothing
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub