パワーポイント上の図形に自動的に色を塗る方法（VBA、VBScript）

ChatGPT（2022年11月30日公開）やStable Diffusion（2022年8月22日公開）など、大規模言語モデルや画像生成AIは、その存在感をますます増している。

僕も毎日、未知の扉を開けるような興奮を感じながら生成AIといえる存在に触れ、それが日常の一部となっている。

アイデア制作
ロゴ・アイコン・画像素材制作
文章の作成
調査内容の提案
会話相手

例えば、新しいプロジェクトの着想に困ったときは、生成AIにアイデアをもたらしてもらい独自の表現を見つけている。

ChatGPTに提示してもらう知識の海を垣間見るたびに、僕の創造力がツールを通じて新たな高みに到達していると感じてる。

もっとも大きいことは、生成AIがコードを書いてくれることで、ソースコード実装の工数が従来の半分に減少した。

パワーポイント上の図形に自動的に色を塗る方法
VBScriptで書いてもらう
おわりに

そのある日の会社での委託さんとのやり取り。

私「パワーポイント上で特定の文字の入った図形を検索して一致したら自動的に色を塗るシステム作って」

委託リーダー「パワーポイント上では難しいのでは……。ウェブならできるかも」

私「ウェブじゃなくて、パワーポイントでやって。」

委託リーダー「色々と調査が必要なので、数週間はかかるかと・・・」

……。

この議論してる間にChatGPTが作ってくれた。

書いたコードも期待通りだし、使い方の説明まで完璧♪

パワーポイント上の図形に自動的に色を塗る方法

【私の質問】

パワーポイントで、複数の特定の文字の入った図形を検索してヒットした図形の配色を赤に変えたい。何のプログラム言語を使って、どう書けば良いですか？

【ChatGPTの回答】

PowerPointで特定の文字を含む図形を検索し、その図形の配色を変更するには、VBA（Visual Basic for Applications）を使用するのが一般的です。VBAはMicrosoft Office製品に組み込まれたプログラミング言語であり、PowerPointにも組み込まれています。

以下は、PowerPointのVBAを使用して特定の文字を含む図形を検索し、その図形の配色を赤に変更する簡単なスクリプトの例です。

PowerPointを開きます。
Alt + F11 キーを押してVBAエディタを開きます。
Insert メニューから Module を選択して新しいモジュールを挿入します。
以下のコードを貼り付けます。

Sub ChangeColorOfShapes()
    Dim slide As slide
    Dim shape As shape
    
    ' 対象の文字列
    Dim targetText As String
    targetText = "特定の文字列"
    
    ' 色を変更する色（赤）
    Dim newColor As Long
    newColor = RGB(255, 0, 0)
    
    ' 各スライドをループ
    For Each slide In ActivePresentation.Slides
        ' 各図形をループ
        For Each shape In slide.Shapes
            ' テキストボックスかつ対象の文字列が含まれている場合
            If shape.HasTextFrame Then
                If InStr(1, shape.TextFrame.TextRange.Text, targetText, vbTextCompare) > 0 Then
                    ' 配色を変更
                    shape.Fill.ForeColor.RGB = newColor
                End If
            End If
        Next shape
    Next slide
End Sub

Sub ChangeColorOfShapes()

Dim slide As slide

Dim shape As shape

' 対象の文字列

Dim targetText As String

targetText = "特定の文字列"

' 色を変更する色（赤）

Dim newColor As Long

newColor = RGB(255, 0, 0)

' 各スライドをループ

For Each slide In ActivePresentation.Slides

' 各図形をループ

For Each shape In slide.Shapes

' テキストボックスかつ対象の文字列が含まれている場合

If shape.HasTextFrame Then

If InStr(1, shape.TextFrame.TextRange.Text, targetText, vbTextCompare) > 0 Then

' 配色を変更

shape.Fill.ForeColor.RGB = newColor

End If

Next shape

Next slide

End Sub

targetText 変数に検索したい文字列を設定します。
Run ボタン（または F5 キー）を押してスクリプトを実行します。

このスクリプトは、プレゼンテーション内のすべてのスライドおよび図形をチェックし、指定した文字列を含む図形の塗りつぶし色を赤に変更します。特定の条件に基づいてスクリプトを変更することができます。

VBScriptで書いてもらう

VBScriptは通常はWindows Script Host (WSH) 環境で実行されるため、直接PowerPointにアクセスすることが難しいですが、PowerPointのCOMオブジェクトを使用してVBScript内でPowerPointを制御する方法があります。

以下は、VBScriptでPowerPointの図形の色を変更する簡単な例です。このスクリプトを .vbs ファイルとして保存し、PowerPointファイルをスクリプトにドラッグすると、指定されたCSVファイルから文字列と色情報を読み取り、それに一致する図形の色を変更します。

Option Explicit

Dim PowerPointApp
Set PowerPointApp = CreateObject("PowerPoint.Application")
PowerPointApp.Visible = True ' PowerPointを表示するかどうか

' PowerPointファイルがスクリプトにドラッグされたかどうかを確認
If WScript.Arguments.Count = 0 Then
    WScript.Echo "このスクリプトはPowerPointファイルを引数として受け取る必要があります。"
    WScript.Quit
End If

' PowerPointファイルのパス
Dim presentationPath
presentationPath = WScript.Arguments(0)

' CSVファイルのパス
Dim csvPath
csvPath = Replace(presentationPath, ".pptx", ".csv")

' PowerPointプレゼンテーションを開く
Dim presentation
Set presentation = PowerPointApp.Presentations.Open(presentationPath)

' CSVファイルから文字列と色情報を読み取り
Dim fso, file, lines, line, data, targetText, targetColor
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(csvPath) Then
    Set file = fso.OpenTextFile(csvPath, 1) ' 1は読み取りモード
    lines = Split(file.ReadAll, vbCrLf)
    file.Close

    For Each line In lines
        data = Split(line, ",")
        If UBound(data) = 1 Then
            targetText = Trim(data(0))
            targetColor = "&H" & Replace(data(1), "0x", "")
            
            ' 各スライドをループ
            Dim slide, shape
            For Each slide In presentation.Slides
                ' 各図形をループ
                For Each shape In slide.Shapes
                    ' テキストボックスかつ対象の文字列が含まれている場合
                    If shape.HasTextFrame Then
                        If InStr(1, shape.TextFrame.TextRange.Text, targetText, vbTextCompare) > 0 Then
                            ' 配色を変更
                            shape.Fill.ForeColor.RGB = targetColor
                        End If
                    End If
                Next
            Next
        End If
    Next
End If

' PowerPointプレゼンテーションを保存して閉じる
presentation.Save
presentation.Close
PowerPointApp.Quit

' オブジェクトを解放
Set PowerPointApp = Nothing
Set presentation = Nothing
Set fso = Nothing
Set file = Nothing

WScript.Quit

Option Explicit

Dim PowerPointApp

Set PowerPointApp = CreateObject("PowerPoint.Application")

PowerPointApp.Visible = True ' PowerPointを表示するかどうか

' PowerPointファイルがスクリプトにドラッグされたかどうかを確認

If WScript.Arguments.Count = 0 Then

WScript.Echo "このスクリプトはPowerPointファイルを引数として受け取る必要があります。"

WScript.Quit

End If

' PowerPointファイルのパス

Dim presentationPath

presentationPath = WScript.Arguments(0)

' CSVファイルのパス

Dim csvPath

csvPath = Replace(presentationPath, ".pptx", ".csv")

' PowerPointプレゼンテーションを開く

Dim presentation

Set presentation = PowerPointApp.Presentations.Open(presentationPath)

' CSVファイルから文字列と色情報を読み取り

Dim fso, file, lines, line, data, targetText, targetColor

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FileExists(csvPath) Then

Set file = fso.OpenTextFile(csvPath, 1) ' 1は読み取りモード

lines = Split(file.ReadAll, vbCrLf)

file.Close

For Each line In lines

data = Split(line, ",")

If UBound(data) = 1 Then

targetText = Trim(data(0))

targetColor = "&H" & Replace(data(1), "0x", "")

' 各スライドをループ

Dim slide, shape

For Each slide In presentation.Slides

' 各図形をループ

For Each shape In slide.Shapes

' テキストボックスかつ対象の文字列が含まれている場合

If shape.HasTextFrame Then

If InStr(1, shape.TextFrame.TextRange.Text, targetText, vbTextCompare) > 0 Then

' 配色を変更

shape.Fill.ForeColor.RGB = targetColor

End If

' PowerPointプレゼンテーションを保存して閉じる

presentation.Save

presentation.Close

PowerPointApp.Quit

' オブジェクトを解放

Set PowerPointApp = Nothing

Set presentation = Nothing

Set fso = Nothing

Set file = Nothing

WScript.Quit

おわりに

ブログ作成もほぼChatGPTで出来たわｗｗ

もう人間いらないじゃんｗｗ

Yahoo知恵袋なんてゴミだねｗｗ

【付録】上記3行をChatGPTが書き換えた場合

ブログの執筆、それはまるで心の奥底から湧き上がる言葉が、紙面上に舞い降りるかのような感覚だった。ChatGPTという存在が、まさに筆舌に尽くしがたい創造性の泉となり、私の思考を紡ぎだしてくれた。

人間に頼ることなく、この機械の魔法のような力で、ブログの文字が綴り出される。まるで文学の魔法使いが、言葉の精霊たちと共に舞い踊るような情景が目の前に広がる。

かつてYahoo知恵袋と呼ばれた場所など、もはや価値のある言葉の交換が行われる場所ではない。知識と創造性が、このChatGPTの存在によって、新しい高みに昇華されていく。人間の手によるものを超越した純粋な文学の表現が、今ここに生まれているのだ。