PowerPointの埋め込みグラフの色を一括で変更するVBAマクロ

changeGraphColor.bas

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public BorderColor  As Integer, MarkerColor As Integer

'
' スライド全体の埋め込みグラフの色を１つ目のグラフに合わせて変更します
' MacではGraph編集機能の起動・終了のタイミングがあわず
' 上手く処理できないグラフが出ることがあります
'
Sub changeGraphColor()
    BorderColor = -1
    MarkerColor = -1

    For i = 1 To ActivePresentation.Slides.Count
        Debug.Print "Sheet", i
        changeSlide ActivePresentation.Slides(i)
    Next

    Debug.Print "Finish"
    MsgBox "グラフ色かえ終了"

End Sub


Private Sub changeSlide(slide)

   Dim i As Integer
   Dim shapes As PowerPoint.shapes
   Dim sh As PowerPoint.Shape

   Set shapes = slide.shapes

   For i = 1 To shapes.Count
       Set sh = shapes(i)
       If sh.type = 7 Then
           If sh.OLEFormat.ProgID Like "MSGraph.Chart.*" Then

               Debug.Print "  Shape", i, sh.Name
               modify sh.OLEFormat

               DoEvents
               Sleep 500

           End If
       End If
   Next

End Sub

Private Sub modify(oleObj As Object)
    On Error GoTo ErrorTrap

    Dim objGraph As Object

    'oleObj.Activate
    Set objGraph = oleObj.Object
    modifyGraph objGraph.Application

    On Error GoTo 0
    Exit Sub

ErrorTrap:
    Debug.Print "    Error: Could't get Graph.  No." & Err.Number, "エラー内容：" & Err.Description
    Resume Next
End Sub


Private Sub modifyGraph(graph)
    Dim sc, c
    On Error GoTo ErrorTrap2

    Set sc = graph.Chart.SeriesCollection
    Set c = sc(1)

    ' 対象をスライドの内容に応じて制限
    If c.chartType = xlLineMarkers And sc.Count = 1 And c.Points.Count >= 13 Then
        'Debug.Print c.Border.ColorIndex, c.MarkerBackgroundColor

        If BorderColor = -1 Then
            BorderColor = c.Border.ColorIndex
            MarkerColor = c.MarkerBackgroundColor
            Debug.Print "    Pickup Color"

        Else
            c.Border.ColorIndex = BorderColor
            c.MarkerBackgroundColorIndex = MarkerColor

            graph.Update
            Debug.Print "    Update"

        End If

    Else
        Debug.Print "    Skip"

    End If
    graph.Quit

    On Error GoTo 0
    Exit Sub

ErrorTrap2:
    Debug.Print "    Error: Couldn't change graph. No." & Err.Number, "エラー内容：" & Err.Description
    graph.Quit

End Sub