昔のアニメ映画の予告編みたいな文字送り

今も印象深く心に残っているのが、小学生の時に見たアニメ映画
「幻魔大戦」
の劇場予告編だ。

↓ ※音が出たらマズイ人は、ご注意ください。
youtu.be

この「幻魔大戦」の４文字の出し方が、子供ながらに格好良いと
思った。そこで今回は、これをExcel で疑似的に再現してみよう。

今回はワードアートを使った文字で、等間隔に並べてみることにした。
それっぽいフォント名やサイズで、まず決め打ちで作ってみた。

Function WardArt(display_characters As String) As Excel.Shape
    Set WardArt = ActiveSheet.Shapes.AddTextEffect(PresetTextEffect:=msoTextEffect45, _
                                                 Text:=display_characters, _
                                                 FontName:="+mn-lt", _
                                                 FontSize:=54, _
                                                 FontBold:=msoTrue, _
                                                 FontItalic:=msoFalse, _
                                                 Left:=0, _
                                                 Top:=0)
        With WardArt.TextFrame2.TextRange.Font
            .NameComplexScript = "HGSｺﾞｼｯｸE"
            .NameFarEast = "HGSｺﾞｼｯｸE"
            .Name = "HGSｺﾞｼｯｸE"
        End With
End Function

これまた決め打ちで、文字を並べてみた。

Sub 幻魔大戦()

    ' 表示する文字。
    Dim waArr() As Excel.Shape
    ReDim waArr(4, 5)
    
    ' 縦並びのループカウンタ。
    Dim i As Long
    ' 横並びのループカウンタ。
    Dim j As Long
    ' 文字用のループカウンタ。
    Dim k As Long
    
    ' 表示する文字列。
    Dim TextArray As Variant
        TextArray = Array("幻", "魔", "大", "戦")
        
        ' 「幻」の文字を等間隔に表示。
        ' ３行２列目だけ赤に。
        For j = 0 To 5
            For i = 0 To 4
                Set waArr(i, j) = WardArt(CStr(TextArray(0)))
                    waArr(i, j).Top = i * 60
                    waArr(i, j).Left = j * 60
                    If i = 2 And j = 1 Then
                        waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(192, 0, 0)
                    End If
            Next
            
            ' １列毎に少し止める。
            Application.Wait [Now() + "00:00:00.3"]
        Next
        
        ' セットした文字を、「魔・大・戦」の順に入れ替えていく。
        ' ただし、赤色の文字はそのままにしておく。
        ' 「幻魔大戦」が中央に書かれるよう、赤い文字の後ろは赤に。
        For k = 1 To 3
            For j = 0 To 5
                For i = 0 To 4
                    If waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB <> RGB(192, 0, 0) Then
                        waArr(i, j).TextFrame2.TextRange.Characters.Text = TextArray(k)
                    End If
                    If i = 2 And j = k + 1 Then
                        waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(192, 0, 0)
                    End If
                Next
                Application.Wait [Now() + "00:00:00.3"]
            Next
        Next
        
        ' 赤以外の文字は消す。
        Application.Wait [Now() + "00:00:01"]
        For j = 0 To 5
            For i = 0 To 4
                If waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB <> RGB(192, 0, 0) Then
                    waArr(i, j).Delete
                End If
            Next
        Next
End Sub

結果がこちら。

それなりに、それっぽくなったかな。
決め打ち部分をもう少し工夫すれば、汎用的に使えるかも。

参考まで。