参考ページ
https://docs.microsoft.com/ja-jp/office/vba/api/overview/
https://www.relief.jp/PowerPoint-VBA/
目的
新年度になり、飲み会の余興でチーム対抗クイズをしたいということなった。
新たにアプリを作ったりするのは、手間が大きいので、パワポを使って行うことになったが、
パワポはそのままではスライドショー中に内容を変更できないため、
得点の表示をすることが難しかったので、VBAを使って簡単なマクロを組んで
得点を表示をできるようにしたい。
イメージ
ここでは「テスト青」が正解したとする。
仕様
2台のPCからアクセスできる領域(2台のPCのどちらかをファイル共有可能にする、NASを使うなど)にcsvファイルを置き、クイズと得点を表示をするスライドの得点表にcsvの内容を反映させる。
これを定時実行させる(実際は定時実行はできなかったので、次のスライドに移動する、もしくはボタンを押すと反映するようになっている)
環境
vbaが動けばいいので、MacOS(OSX含む)、Windowsはあまり関係ないと思われる。
自分が動かした環境は
MacOS 10.14.3（18D109）が2台
Microsoft PowerPoint for Mac 16.16.9
スライドには2行の表がある。
csvファイルは2行であり、2行めには各チームの得点が入っている。
マクロの書き方
マクロをクリックして編集をクリックすると編集画面が出るので、そこで書き込む.。
ソースコード
Sub point()
DoEvents
Dim os As String
Dim cells() As String ' 表内の文字列格納用配列
Dim s_cnt As Long ' スライド数格納用
Dim r As Long ' 行方向ループのカウンタ
Dim c As Long ' 列方向ループのカウンタ
Dim s As Long ' スライドループのカウンタ
Dim sh_cnt As Long 'shpを持っているかを確認するカウンタ
Dim sh_has() As Boolean 'shp を持っているか
Dim point_stg As String 'csvの中身
Dim point() As String 'csv の中身を分割したもの
s_cnt = ActivePresentation.Slides(ActivePresentation.Slides.Count).SlideNumber ' スライドの総数を取得
ReDim sh_has(1 To s_cnt)
sh_cnt = 1
Dim sld As Slide
Dim shp As Shape
' スライド内に表が あるスライドを保存
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
sh_has(sh_cnt) = True
Else
sh_has(sh_cnt) = False
End If
sh_cnt = sh_cnt + 1
Exit For
Next shp
Next sld
'ファイル取得
point_stg = File_load
' ファイルが見つかっている状態の場合
If point_stg <> "Not_fand" Then
'全スライドに対して
For s = 1 To s_cnt
' 表があるか確認
If sh_has(s) Then
' 1番の表をcsvファイルの内容で更新
With ActivePresentation.Slides(s).Shapes(1).Table
ReDim cells(1 To .Rows.Count, 1 To .Columns.Count)
point = Split(point_stg, ",")
For c = 1 To .Columns.Count
_
.Cell(2, c).Shape.TextFrame.TextRange.Text = point(c - 1)
Next c
End With
End If
Next s
End If
Exit Sub
End Sub
'スライドが移動したらpointを呼ぶ
Sub OnSlideShowPageChange(ByVal ss As SlideShowWindow)
Dim n As Long
n = ss.View.CurrentShowPosition
Select Case n
Case n
point
Case Else
End Select
End Sub
'スライド1のタイトルをファイルパスとし て取得し、内容を読み込む
Function File_load()
On Error GoTo ERR_HNDL
Dim csv_path As String
csv_path = ActivePresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text
Dim buf As String
Open csv_path For Input As #1
Do Until EOF(1)
Line Input #1, buf
Loop
Close #1
File_load = buf
Exit Function
ERR_HNDL:
MsgBox " ファイルが見つかりませんでした"
File_load = "Not_fand"
End Function
ソースの解説
ファイルの読み込み
'スライド1のタイトルをファイルパスとし て取得し、内容を読み込む
Function File_load()
On Error GoTo ERR_HNDL
Dim csv_path As String
csv_path = ActivePresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text
Dim buf As String
Open csv_path For Input As #1
Do Until EOF(1)
Line Input #1, buf
Loop
Close #1
File_load = buf
Exit Function
ERR_HNDL:
MsgBox " ファイルが見つかりませんでした"
File_load = "Not_fand"
End Function
スライド1を非表示スライドに設定してスライド1のタイトルに入力された文字列をファイルパスとして取得するようにした。
ソースコードに直接書いてもよかったが、後からファイルのパスを変更できた方が良いという判断からこうした。
読み込んだcsvファイルの１番下の行を文字列を文字列として読み込み返す。
ファイルが見つからなかった場合はエラーを示す、"Not_fand"を返す。
ファイルを読み込むとMacOSだとではファイルアクセスの許可を求められるので許可する。
(多分Windowsでも)
スライド移動時
'スライドが移動したらpointを呼ぶ
Sub OnSlideShowPageChange(ByVal ss As SlideShowWindow)
Dim n As Long
n = ss.View.CurrentShowPosition
Select Case n
Case n
point
Case Else
End Select
End Sub
スライド移動時に、得点更新用の関数呼ぶ。
得点の更新
Sub point()
DoEvents
Dim os As String
Dim cells() As String ' 表内の文字列格納用配列
Dim s_cnt As Long ' スライド数格納用
Dim r As Long ' 行方向ループのカウンタ
Dim c As Long ' 列方向ループのカウンタ
Dim s As Long ' スライドループのカウンタ
Dim sh_cnt As Long 'shpを持っているかを確認するカウンタ
Dim sh_has() As Boolean 'shp を持っているか
Dim point_stg As String 'csvの中身
Dim point() As String 'csv の中身を分割したもの
s_cnt = ActivePresentation.Slides(ActivePresentation.Slides.Count).SlideNumber ' スライドの総数を取得
ReDim sh_has(1 To s_cnt)
sh_cnt = 1
Dim sld As Slide
Dim shp As Shape
' スライド内に表が あるスライドを保存
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
sh_has(sh_cnt) = True
Else
sh_has(sh_cnt) = False
End If
sh_cnt = sh_cnt + 1
Exit For
Next shp
Next sld
'ファイル取得
point_stg = File_load
' ファイルが見つかっている状態の場合
If point_stg <> "Not_fand" Then
'全スライドに対して
For s = 1 To s_cnt
' 表があるか確認
If sh_has(s) Then
' 1番の表をcsvファイルの内容で更新
With ActivePresentation.Slides(s).Shapes(1).Table
ReDim cells(1 To .Rows.Count, 1 To .Columns.Count)
point = Split(point_stg, ",")
For c = 1 To .Columns.Count
_
.Cell(2, c).Shape.TextFrame.TextRange.Text = point(c - 1)
Next c
End With
End If
Next s
End If
Exit Sub
End Sub
もう少し関数に分けるなどをすれば、よかった。
基本的にはコメントに書いてある通りで、ファイルが見つかった場合、表番号1番の内容を、csvファイルのから取得した文字列で順番に書き換えていく。
パワポでは表を作ると番号振られているようがどれが何番になるのかは、わからないので1スライドにつき1つの表にするのが安全。
本当は表示中のスライドのみを表があるのか判定して、更新するのが良いが、気がつくの遅かったのと、パワポは複数ディスプレイでスライドショーをしていると、次のスライドの内容が操作している人には見えるので、得点が更新されていないように見えることから、今回は修正しなかった。
ボタンの作成
後はスライドを移動しないと得点が更新されないのは、不便なので、手動でも更新できるように図形の挿入で動作設定ボタンを入れる。マクロ実行を選んで、実行するマクロは"point"を選択。カーソルが通過するだけでOKにするのか、クリックするのかは目的に合わせて変更。
ボタンがこのままだとボタンがスライドショー中に見えてカッコ悪いのでボタンを図形の書式設定から透明かする。(ボタン位置が見えなくなるので位置覚えておく、位置を右下の角に置くなど分かりやすくする)
定時実行について
冒頭にもある通り本来定時実行が望ましいが、excelにはあるApplication.OnTimeがパワポにはなかった。AppleScriptなどと繰り合わせて作るなどといった方法もあるが、そこまでの気力はなかったので、今回は諦めた。