【ChatGPT✖️PowerPoint】フラッシュ暗算を作ってみた - コトゼニ～学習塾とボクと、時々プログラミング〜

【PR】この記事には広告を含む場合があります。

記事内で紹介する商品を購入することで、当サイトに売り上げの一部が還元されることがあります。

突然ですが、とあるきっかけから、フラッシュ暗算が必要になったのですが、インターネット上にもあるアプリケーションだと、

フラッシュ秒数が早い
桁数などの調整ができない

という点があったため、PowerPointを使って実現できないかということを考えてチャレンジしました。

以前にPowerPointにマクロを搭載させることに成功していたので、今回もChatGPTを使って制作してみました。

▶︎こちらの記事でも紹介しています。

2023年7月24日【ChatGPT×PowerPoint】スライドをJPEG出力するマクロを作った話

ChatGPTがコードを作成してくれる能力の高さはすでに証明されているので、具体的なコードも大切ですが、投げかけるプロンプトがもっと大切なので、投げかけたプロンプトを中心に紹介します。

投げかけたプロンプト

それでは早速、ChatGPTに投げかけプロンプトを順に紹介します。

コトゼニ

PowerPointでフラッシュ暗算を作りたいです。マクロを使って実現できませんか？出題する桁数と回数を指定できるようにしたいです

chatGPT

フラッシュ暗算の出題する桁数と回数を指定できるようにするために、VBA（Visual Basic for Applications）マクロを使用することは可能です。

Sub CreateFlashArithmetic()
    Dim SlideCount As Integer
    Dim Digits As Integer
    Dim i As Integer
    
    ' ダイアログボックスで出題回数を取得
    SlideCount = InputBox("出題回数を入力してください:", "フラッシュ暗算", 1)
    
    ' ダイアログボックスで桁数を取得
    Digits = InputBox("桁数を入力してください:", "フラッシュ暗算", 2)
    
    ' プレゼンテーションを作成
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Dim pptPresentation As Object
    Set pptPresentation = pptApp.Presentations.Add
    
    ' フラッシュ暗算の問題を生成してスライドに追加
    For i = 1 To SlideCount
        Dim Question As String
        Dim Answer As String
        Question = GenerateRandomQuestion(Digits)
        Answer = Evaluate(Question)
        
        ' 新しいスライドを追加
        Dim pptSlide As Object
        Set pptSlide = pptPresentation.Slides.Add(i, ppLayoutText)
        
        ' 問題文を挿入
        pptSlide.Shapes(1).TextFrame.TextRange.Text = "問題 " & i & ": " & Question
        
        ' 答えを挿入
        pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
          Left:=100, Top:=200, Width:=400, Height:=100).TextFrame.TextRange.Text = "答え: " & Answer
    Next i
End Sub

Function GenerateRandomQuestion(Digits As Integer) As String
    Dim Question As String
    Dim i As Integer
    For i = 1 To Digits
        Question = Question & Int(Rnd() * 10)
    Next i
    GenerateRandomQuestion = Question
End Function

このコードを実行するとこのような結果となりました。

これだと、「問題」という文言が邪魔ですね。

コトゼニ

ここから改良を加えたいです。・問題文を表示する際に「問題i:」の表記を削除・出題した数字を足し合わせた答えを最後にスライドに表示させる。

chatGPT

問題文の「問題i:」の表記を削除し、出題した数字を足し合わせた答えを最後にスライドに表示させるために、以下の修正を加えたVBAマクロを提供します。

Sub CreateFlashArithmetic()
    Dim SlideCount As Integer
    Dim Digits As Integer
    Dim i As Integer
    Dim AnswerSum As Double
    
    ' ダイアログボックスで出題回数を取得
    SlideCount = InputBox("出題回数を入力してください:", "フラッシュ暗算", 1)
    
    ' ダイアログボックスで桁数を取得
    Digits = InputBox("桁数を入力してください:", "フラッシュ暗算", 2)
    
    ' プレゼンテーションを作成
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Dim pptPresentation As Object
    Set pptPresentation = pptApp.Presentations.Add
    
    ' フラッシュ暗算の問題を生成してスライドに追加
    For i = 1 To SlideCount
        Dim Question As String
        Dim Answer As Double
        Question = GenerateRandomQuestion(Digits)
        Answer = Val(Question) ' 数式を評価
        
        ' 新しいスライドを追加
        Dim pptSlide As Object
        Set pptSlide = pptPresentation.Slides.Add(i, ppLayoutText)
        
        ' 問題文を挿入（「問題i:」の表記を削除）
        pptSlide.Shapes(1).TextFrame.TextRange.Text = Question
        
        ' 出題した数字を足し合わせる
        AnswerSum = AnswerSum + Answer
    Next i
    
    ' 答えの合計を最後のスライドに表示
    Dim lastSlide As Object
    Set lastSlide = pptPresentation.Slides.Add(SlideCount + 1, ppLayoutText)
    lastSlide.Shapes(1).TextFrame.TextRange.Text = "すべての問題の答えの合計: " & AnswerSum
End Sub

Function GenerateRandomQuestion(Digits As Integer) As String
    Dim Question As String
    Dim i As Integer
    For i = 1 To Digits
        Question = Question & Int(Rnd() * 10)
    Next i
    GenerateRandomQuestion = Question
End Function

このコードを実行すると、以下のようになりました。たしかに「問題」という文言は消えましたね。

コトゼニ

さらに改良します。以下の要件を満たすように修正してください

【要件】

・「すべての問題の答えの合計：」という文言を「こたえ」に修正。

・問題文のスライドの最初に「フラッシュ暗算を開始」という文言が載ったスライドを挿入（作成）。

・全スライドの背景色を黒にし、全スライドの文字色を黄色にする

・問題文の文字色を黄色にしてフォントサイズを128にして最前面に現れる

Sub CreateFlashArithmetic()
    Dim SlideCount As Integer
    Dim Digits As Integer
    Dim i As Integer
    Dim AnswerSum As Double
    
    ' ダイアログボックスで出題回数を取得
    SlideCount = InputBox("出題回数を入力してください:", "フラッシュ暗算", 1)
    
    ' ダイアログボックスで桁数を取得
    Digits = InputBox("桁数を入力してください:", "フラッシュ暗算", 2)
    
    ' プレゼンテーションを作成
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Dim pptPresentation As Object
    Set pptPresentation = pptApp.Presentations.Add
    
    ' フラッシュ暗算の問題を生成してスライドに追加
    For i = 1 To SlideCount
        Dim Question As String
        Dim Answer As Double
        Question = GenerateRandomQuestion(Digits)
        Answer = Val(Question) ' 数式を評価
        
        ' 新しいスライドを追加
        Dim newSlide As Object
        Set newSlide = pptPresentation.Slides.Add(i, ppLayoutText)
        
        ' スライドの背景に黒い四角形を描画
        DrawBlackRectangle newSlide.Shapes, newSlide
        ' 問題文を挿入
        AddTextToSlide newSlide, Question
        
        ' 出題した数字を足し合わせる
        AnswerSum = AnswerSum + Answer
    Next i
    
    ' 答えの合計を最後のスライドに表示
    Dim lastSlide As Object
    Set lastSlide = pptPresentation.Slides.Add(SlideCount + 1, ppLayoutText)
    
    ' スライドの背景に黒い四角形を描画
    DrawBlackRectangle lastSlide.Shapes, lastSlide
    ' こたえを挿入
    AddTextToSlide lastSlide, "こたえ: " & AnswerSum
End Sub

Sub DrawBlackRectangle(shapes As Object, slide As Object)
    ' スライドの背景に黒い四角形を描画
    Dim left As Single
    Dim top As Single
    Dim width As Single
    Dim height As Single
    left = 0
    top = 0
    width = slide.Master.Width
    height = slide.Master.Height
    shapes.AddShape(Type:=1, Left:=left, Top:=top, Width:=width, Height:=height).Fill.ForeColor.RGB = RGB(0, 0, 0)
End Sub

Sub AddTextToSlide(slide As Object, text As String)
    ' テキストボックスを新しいスライドに追加
    Dim left As Single
    Dim top As Single
    Dim width As Single
    Dim height As Single
    left = 50 ' テキストボックスの位置を調整
    top = 50
    width = 500
    height = 300
    
    ' テキストボックスを追加
    Dim textBox As Object
    Set textBox = slide.Shapes.AddTextbox(Orientation:=1, Left:=left, Top:=top, Width:=width, Height:=height)
    
    ' テキストのフォントサイズと色を設定
    textBox.TextFrame.TextRange.Text = text
    textBox.TextFrame.TextRange.Font.Size = 128
    textBox.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 0) ' 黄色
End Sub

Function GenerateRandomQuestion(Digits As Integer) As String
    Dim Question As String
    Dim i As Integer
    For i = 1 To Digits
        Question = Question & Int(Rnd() * 10)
    Next i
    GenerateRandomQuestion = Question
End Function

ここでは省略していますが、背景を黒にする作戦は、スライドデザインを調整するのではなく「黒色の四角形を後ろに挿入する」という手法を採りました。このアイディアを出してくるあたりも優秀ですね。このコードを実行すると以下のようになりました。

ここからは微調整ですね。

コトゼニ

微調整したいです。文字を中央表示したいです。

chatGPT

テキストを中央に表示するために、テキストボックスの配置を調整できます。以下が、テキストを中央に配置する修正済みのコードです。

Sub CreateFlashArithmetic()
    Dim SlideCount As Integer
    Dim Digits As Integer
    Dim i As Integer
    Dim AnswerSum As Double
    
    ' ダイアログボックスで出題回数を取得
    SlideCount = InputBox("出題回数を入力してください:", "フラッシュ暗算", 1)
    
    ' ダイアログボックスで桁数を取得
    Digits = InputBox("桁数を入力してください:", "フラッシュ暗算", 2)
    
    ' プレゼンテーションを作成
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Dim pptPresentation As Object
    Set pptPresentation = pptApp.Presentations.Add
    
    ' フラッシュ暗算の問題を生成してスライドに追加
    For i = 1 To SlideCount
        Dim Question As String
        Dim Answer As Double
        Question = GenerateRandomQuestion(Digits)
        Answer = Val(Question) ' 数式を評価
        
        ' 新しいスライドを追加
        Dim newSlide As Object
        Set newSlide = pptPresentation.Slides.Add(i, ppLayoutText)
        
        ' スライドの背景に黒い四角形を描画
        DrawBlackRectangle newSlide.Shapes, newSlide
        ' 問題文を挿入
        AddTextToSlide newSlide, Question
        
        ' 出題した数字を足し合わせる
        AnswerSum = AnswerSum + Answer
    Next i
    
    ' 答えの合計を最後のスライドに表示
    Dim lastSlide As Object
    Set lastSlide = pptPresentation.Slides.Add(SlideCount + 1, ppLayoutText)
    
    ' スライドの背景に黒い四角形を描画
    DrawBlackRectangle lastSlide.Shapes, lastSlide
    ' こたえを挿入
    AddTextToSlide lastSlide, "こたえ: " & AnswerSum
End Sub

Sub DrawBlackRectangle(shapes As Object, slide As Object)
    ' スライドの背景に黒い四角形を描画
    Dim left As Single
    Dim top As Single
    Dim width As Single
    Dim height As Single
    left = 0
    top = 0
    width = slide.Master.Width
    height = slide.Master.Height
    shapes.AddShape(Type:=1, Left:=left, Top:=top, Width:=width, Height:=height).Fill.ForeColor.RGB = RGB(0, 0, 0)
End Sub

Sub AddTextToSlide(slide As Object, text As String)
    ' テキストボックスを新しいスライドに追加
    Dim left As Single
    Dim top As Single
    Dim width As Single
    Dim height As Single
    left = (slide.Master.Width - 500) / 2 ' 横方向の中央配置
    top = (slide.Master.Height - 300) / 2 ' 縦方向の中央配置
    width = 500
    height = 300
    
    ' テキストボックスを追加
    Dim textBox As Object
    Set textBox = slide.Shapes.AddTextbox(Orientation:=1, Left:=left, Top:=top, Width:=width, Height:=height)
    
    ' テキストのフォントサイズと色を設定
    textBox.TextFrame.TextRange.Text = text
    textBox.TextFrame.TextRange.Font.Size = 128
    textBox.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 0) ' 黄色
    ' テキストを中央に配置
    textBox.TextFrame.TextRange.ParagraphFormat.Alignment = 2 ' ppAlignCenter
End Sub

Function GenerateRandomQuestion(Digits As Integer) As String
    Dim Question As String
    Dim i As Integer
    For i = 1 To Digits
        Question = Question & Int(Rnd() * 10)
    Next i
    GenerateRandomQuestion = Question
End Function

そしていよいよアニメーションの追加です。

コトゼニ

マクロをさらに改良したいです。以下の要件を満たすようにしてください。

【要件】

問題文のスライドの最初に「フラッシュ暗算を開始」という文言が載ったスライドを挿入（作成）
最後の答えを表示するスライドの直前に「ここまで」という文言を表示・問題文のスライドをすべて作成し終えた後、最初のスライドからスライドショーを開始。
スライドは1秒ごとに次のスライドへ切り替わる。
「ここまで」と表示されたスライドでスライドショーをストップさせる。

chatGPT

要件に従って、マクロを改良し、スライドショーを自動的に開始し、最後のスライドの直前で停止するようにしました。また、フラッシュ暗算を開始するスライドと「ここまで」の表示スライドも追加しました。以下が修正済みのコードです。

Sub CreateFlashArithmetic()
    Dim SlideCount As Integer
    Dim Digits As Integer
    Dim i As Integer
    Dim AnswerSum As Double
    
    ' ダイアログボックスで出題回数を取得
    SlideCount = InputBox("出題回数を入力してください:", "フラッシュ暗算", 1)
    
    ' ダイアログボックスで桁数を取得
    Digits = InputBox("桁数を入力してください:", "フラッシュ暗算", 2)
    
    ' プレゼンテーションを作成
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Dim pptPresentation As Object
    Set pptPresentation = pptApp.Presentations.Add
    
    ' フラッシュ暗算を開始するスライドを挿入
    Dim startSlide As Object
    Set startSlide = pptPresentation.Slides.Add(1, ppLayoutText)
    DrawBlackRectangle startSlide.Shapes, startSlide
    AddTextToSlide startSlide, "フラッシュ暗算を開始", 88
    ' フェードインのアニメーションを付与
    ApplyFadeAnimation startSlide.Shapes(2)
    
    ' フラッシュ暗算の問題を生成してスライドに追加
    For i = 1 To SlideCount
        Dim Question As String
        Dim Answer As Double
        Question = GenerateRandomQuestion(Digits)
        Answer = Val(Question) ' 数式を評価
        
        ' 新しいスライドを追加
        Dim newSlide As Object
        Set newSlide = pptPresentation.Slides.Add(i + 1, ppLayoutText)
        DrawBlackRectangle newSlide.Shapes, newSlide
        ' スライドにテキストを追加
        AddTextToSlide newSlide, Question, 88
        ' フェードインのアニメーションを付与
        ApplyFadeAnimation newSlide.Shapes(2)
        
        ' 出題した数字を足し合わせる
        AnswerSum = AnswerSum + Answer
        
        ' 最後のスライドの直前に「ここまで」と表示するスライドを挿入
        If i = SlideCount Then
            Dim hereSlide As Object
            Set hereSlide = pptPresentation.Slides.Add(i + 2, ppLayoutText)
            DrawBlackRectangle hereSlide.Shapes, hereSlide
            ' スライドにテキストを追加
            AddTextToSlide hereSlide, "ここまで", 88
            ' フェードインのアニメーションを付与
            ApplyFadeAnimation hereSlide.Shapes(2)
        End If
    Next i
    
    ' 最後の答えを表示するスライドを追加
    Dim lastSlide As Object
    Set lastSlide = pptPresentation.Slides.Add(SlideCount + 3, ppLayoutText)
    DrawBlackRectangle lastSlide.Shapes, lastSlide
    ' スライドにテキストを追加
    AddTextToSlide lastSlide, "こたえ: " & AnswerSum, 88
    ' フェードインのアニメーションを付与
    ApplyFadeAnimation lastSlide.Shapes(2)
    
    ' スライドショーを開始
    pptPresentation.SlideShowSettings.StartingSlide = 1
    pptPresentation.SlideShowSettings.EndingSlide = SlideCount + 3 ' 最後のスライドの直前で停止
    pptPresentation.SlideShowSettings.AdvanceMode = 1 ' ppSlideShowUseSlideTimings
    pptPresentation.SlideShowSettings.Run
End Sub

Sub DrawBlackRectangle(shapes As Object, slide As Object)
    ' スライドの背景に黒い四角形を描画
    Dim left As Single
    Dim top As Single
    Dim width As Single
    Dim height As Single
    left = 0
    top = 0
    width = slide.Master.Width
    height = slide.Master.Height
    shapes.AddShape(Type:=1, Left:=left, Top:=top, Width:=width, Height:=height).Fill.ForeColor.RGB = RGB(0, 0, 0)
End Sub

Sub AddTextToSlide(slide As Object, text As String, Optional fontSize As Integer = 128)
    ' テキストボックスを新しいスライドに追加
    Dim left As Single
    Dim top As Single
    Dim width As Single
    Dim height As Single
    left = (slide.Master.Width - 500) / 2 ' 横方向の中央配置
    top = (slide.Master.Height - 300) / 2 ' 縦方向の中央配置
    width = 500
    height = 300
    
    ' テキストボックスを追加
    Dim textBox As Object
    Set textBox = slide.Shapes.AddTextbox(Orientation:=1, Left:=left, Top:=top, Width:=width, Height:=height)
    
    ' テキストのフォントサイズと色を設定
    textBox.TextFrame.TextRange.Text = text
    textBox.TextFrame.TextRange.Font.Size = fontSize
    textBox.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 0) ' 黄色
    ' テキストを中央に配置
    textBox.TextFrame.TextRange.ParagraphFormat.Alignment = 2 ' ppAlignCenter
    
    ' テキストボックスを最前面に移動
    textBox.ZOrder msoBringToFront
End Sub

Sub ApplyFadeAnimation(shape As Object)
    ' フェードインのアニメーションを付与
    Dim fadeAnimation As Object
    Set fadeAnimation = shape.AnimationSettings.Add(1, 2) ' ppEffectAppear, ppAfterPrevious
    fadeAnimation.EntryEffect = 5 ' ppEffectFade
End Sub

Function GenerateRandomQuestion(Digits As Integer) As String
    Dim Question As String
    Dim i As Integer
    For i = 1 To Digits
        Question = Question & Int(Rnd() * 10)
    Next i
    GenerateRandomQuestion = Question
End Function

これで完成しました。このコードで動作しない場合は再度ChatGPTに相談してみることをオススメします。