Powerpoint VBA　三択問題を作る - インストールレスプログラミング( ´ー`)

だいぶパワーポイントから離れていたので，久々に連休ですし，ちょっと続き物を書いてみます。

クイズみたいなものをパワーポイントでやるポイントを載せていきます。

概要
VBAコード
コードの説明

概要

さて，次のようなものを作りました。まだ最低限の実装ですが，基本的な考え方は入れています。

ダウンロードは消去しました。

ファイル名の右についているちっちゃいダウンロードボタンでダウンロードすると，私の環境ではファイル名は文字化けしませんでした。

二つのスライドのみから構成されます。

f:id:chemiphys:20170317231258p:plain

選択肢１～３　と　問題　これら全部にボタンというマクロを動作設定します。

f:id:chemiphys:20170317231311p:plain
スライドは２枚しかありません。しかもそのうち表示用は１枚のみですが，選択肢のボタンを押すと，正誤の判定を行い，問題文を表示したりする図形をクリックすると，次の問題に進む。
１０問終わったら　正答数を返すという動きをしています。

VBAコード

標準モジュール

Option Explicit
Public 問題番号 As Long
Public 正解数 As Long

Sub ボタン(oShp As Shape)
    Select Case oShp.Name
        Case "問題"
            Call 次の問題
        Case "選択肢1"
            Call 正誤判定(1)
        Case "選択肢2"
            Call 正誤判定(2)
        Case "選択肢3"
            Call 正誤判定(3)
    End Select
End Sub

Sub 次の問題()
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)
    Dim 問題表 As Table: Set 問題表 = Sld2.Shapes("問題表").Table
    
    If 問題番号 = 0 Then
        正解数 = 0
    End If
    問題番号 = 問題番号 + 1
Stop
    Sld1.Shapes("問題").TextFrame.TextRange.Text = 問題表.Cell(問題番号 + 1, 2).Shape.TextFrame.TextRange.Text
    Sld1.Shapes("選択肢1").TextFrame.TextRange.Text = 問題表.Cell(問題番号 + 1, 3).Shape.TextFrame.TextRange.Text
    Sld1.Shapes("選択肢2").TextFrame.TextRange.Text = 問題表.Cell(問題番号 + 1, 4).Shape.TextFrame.TextRange.Text
    Sld1.Shapes("選択肢3").TextFrame.TextRange.Text = 問題表.Cell(問題番号 + 1, 5).Shape.TextFrame.TextRange.Text
     
End Sub

Sub 正誤判定(argNo As Long)
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2)
    Dim 問題表 As Table: Set 問題表 = Sld2.Shapes("問題表").Table
    
    Dim Ret As String
    If argNo = CLng(問題表.Cell(問題番号 + 1, 6).Shape.TextFrame.TextRange.Text) Then
        Ret = "正解です　おめでとう!　次の問題へ行くにはここをクリック"
        正解数 = 正解数 + 1
    Else
        Ret = "間違いです。正解は" & 問題表.Cell(問題番号 + 1, 6).Shape.TextFrame.TextRange.Text & "番です。" & _
        vbCrLf & "　次の問題へ行くにはここをクリック"
    End If
    Sld1.Shapes("問題").TextFrame.TextRange.Text = Ret
    If 問題番号 = 10 Then
        Ret = Ret & vbCrLf & "１０問終わりました。　正答数は " & 正解数 & "です。おつかれさまでした。" & _
        vbCrLf & "再度挑戦するなら，問題をクリックしてください。"
        Sld1.Shapes("問題").TextFrame.TextRange.Text = Ret
        問題番号 = 0
    End If
End Sub