卓球動画にスコア表示を追加する方法について考察

卓球の試合を撮影して整理しているとスコア表示を追加したいという欲求が出てくると思います。
卓球に疎いジジババなど親類縁者に動画を観てもらうと特にそう感じます。
子供の姿に一喜一憂するものの試合経過がわからず勝ったのか負けたのかもさっぱりという反応をもらいます。
そこでなんとかやってみようということで、でもどのようにすればいいのかわからず試行錯誤しています。

最初に探したのがプログラムで自動作成してくれるものがあるかどうか。
これについては海外サイトを含めて良いものは見つかりませんでした。
野球のスコア表示はありました。試合の動画を流しながらスコアを変えていってまるごとキャプチャするという、
なんとも試合展開がゆっくりしている競技に向いている方法だよねという仕様だしそもそも得点の表示方法が全く違います。
さる日本の方がバスケットの動画を放り込んで表示させながらスコア表示を作っていくというHD動画専用の
ツールを公開されていましたが、これも得点表示形式の違いから卓球には応用できませんでした。

ではスコア表示を手で作成する方法をいろいろ考えたのですが、一点ごとに異なる画像を作るのは大変です。
そこである方がエクセルで作るというアイデアを披露していたので、得点やゲームカウントそしてサーブ権の推移を
表にまとめて、一気にスコア表示の画像を作るマクロを考えることにしました。

スコアデータの表はこんなかんじです。



表のフォーマットについて説明しなくともお分かりいただけるとおもうのですが、念の為。
Player 1とPlayer 2のそれぞれの得点の移り変わりをScore 1とScore 2の行に左から順に記入していきます。
データが終わる印として1行目の最後に半角大文字でEOFと記入する約束にしています。
サーブ権をもっているプレイヤーの番号をServer行に記入します。
ゲームカウントもプレイヤーごとにGame 1よGame 2の行に記入していきます。
このデータからマクロで作成した画像が以下のようになります。



さてこのようにして得点の画像データを簡単に作成できるようにしましたが、問題はここからです。
5ゲームマッチとして一試合あたり少なくとも30枚以上、多ければ100枚以上の得点画像を動画に追加する必要があります。
その追加作業をどのように効率化できるはまた研究してみたいと思います。

Excelのファイルをそのままダウンロードいただけるようにするのは、マクロ付きなので控えます。
そのかわりにマクロをここに記載しておこうと思います。
これをとりこみマクロつきテンプレート（拡張子 .xltm）として保存してください。
Sheet1にデータを記述し、マクロを実行するとScorePictsというシートを追加し結果を保存します。

プレイヤーの名前表示はHG丸ゴシックM-PROという書体を使用しています。スコア表示はLucida Console書体です。
PCに書体がないときは他の書体を選定してください、その場合はセルの高さ幅、文字の表示位置などを微調整する必要があります。

一日で作成したものなので不具合があるかもしれません。これによる結果については一切保証いたしません。

----- ここから -----
Sub createScoreFig()
'
' create Score figures
'
Dim irow As Integer
Dim icol As Integer
Dim jcol As Integer
Dim jrow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim colmax As Integer
'
irow = 2
icol = 2
colmax = 500
j = 0
k = 0
'
jcol = 5
jrow = 1
'
namefield = 25
namelen = WorksheetFunction.Max(Len(Worksheets("sheet1").Cells(4, 2).Value), Len(Worksheets("sheet1").Cells(5, 2).Value))
If namelen > 8 Then
namefield = Int(namelen * 3)
End If
If namefield > 50 Then
namefield = 50
End If
'
' disable screen update to enhance speed
'
Application.ScreenUpdating = False
'
' add a work sheet
'
Worksheets.Add After:=Worksheets("Sheet1")
ActiveSheet.Name = "ScorePicts"
ActiveWindow.DisplayGridlines = False
'
' column formatting
'
Columns(2).ColumnWidth = 0.69
Columns(3).ColumnWidth = namefield
Columns(4).ColumnWidth = 4
Columns(5).ColumnWidth = 6.25

Columns(7).ColumnWidth = 0.69
Columns(8).ColumnWidth = namefield
Columns(9).ColumnWidth = 4
Columns(10).ColumnWidth = 6.25

Columns(12).ColumnWidth = 0.69
Columns(13).ColumnWidth = namefield
Columns(14).ColumnWidth = 4
Columns(15).ColumnWidth = 6.25

Columns(17).ColumnWidth = 0.69
Columns(18).ColumnWidth = namefield
Columns(19).ColumnWidth = 4
Columns(20).ColumnWidth = 6.25

Columns(22).ColumnWidth = 0.69
Columns(23).ColumnWidth = namefield
Columns(24).ColumnWidth = 4
Columns(25).ColumnWidth = 6.25

Columns(4).HorizontalAlignment = xlCenter
Columns(9).HorizontalAlignment = xlCenter
Columns(14).HorizontalAlignment = xlCenter
Columns(19).HorizontalAlignment = xlCenter
Columns(24).HorizontalAlignment = xlCenter
'
' main loop
'
For i = 0 To colmax Step 1
If Worksheets("Sheet1").Cells(jrow, jcol).Value <> "EOF" Then
'
' row formatting
'
Rows(irow + k).RowHeight = 33
Rows(irow + k + 1).RowHeight = 33
Rows(irow + k).VerticalAlignment = xlTop
Rows(irow + k + 1).VerticalAlignment = xlTop
'
' Server mark
'
If Worksheets("Sheet1").Cells(jrow + 2, jcol).Value = 1 Then
Cells(irow + k, icol + j).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 192
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
Cells(irow + k + 1, icol + j).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 192
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
'
' Name
'
Cells(irow + k, icol + j + 1) = Worksheets("sheet1").Cells(4, 2).Value
Cells(irow + k + 1, icol + j + 1) = Worksheets("sheet1").Cells(5, 2).Value
'
' Game count
'
Cells(irow + k, icol + j + 2) = Worksheets("sheet1").Cells(jrow + 3, jcol).Value
Cells(irow + k + 1, icol + j + 2) = Worksheets("sheet1").Cells(jrow + 4, jcol).Value
'
' Score
'
Cells(irow + k, icol + j + 3) = Worksheets("sheet1").Cells(jrow, jcol).Value
Cells(irow + k + 1, icol + j + 3) = Worksheets("sheet1").Cells(jrow + 1, jcol).Value
'
' fill color, text font=HG丸ｺﾞｼｯｸM-PRO
'
Range(Cells(irow + k, icol + j + 1), Cells(irow + k + 1, icol + j + 3)).Select
With Selection.Font
.Name = "HG丸ｺﾞｼｯｸM-PRO"
.FontStyle = "太字"
.Size = 24
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection.Interior
.Pattern = xlPatternLinearGradient
.Gradient.Degree = 270
.Gradient.ColorStops.Clear
End With
With Selection.Interior.Gradient.ColorStops.Add(0)
.ThemeColor = xlThemeColorAccent5
.TintAndShade = -0.498031556138798
End With
With Selection.Interior.Gradient.ColorStops.Add(1)
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.250984221930601
End With

Range(Cells(irow + k, icol + j + 2), Cells(irow + k + 1, icol + j + 3)).Select
With Selection.Font
.Name = "Lucida Console"
.FontStyle = "標準"
.Size = 24
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With

Range(Cells(irow + k, icol + j + 3), Cells(irow + k + 1, icol + j + 3)).Select
With Selection.Font
.Color = -16711681
.TintAndShade = 0
End With

j = j + 5
If j > 24 Then
j = 0
k = k + 3
End If
jcol = jcol + 1
End If
Next i
'
' return to nomal
'
Application.ScreenUpdating = True
Cells(2, 2).Select
End Sub