VBA オートシェイプを使って般若心経をスクロールするアニメーション

今回の記事はオートシェイプを左から右へスクロールさせながらメッセージを表示させるマクロ。
ありがたいお経を題材にしてみた。
f:id:t-hom:20190217162212g:plain

コード

クラスモジュール

クラス名は「CharBox」として、以下のコードを張り付ける。

Private sh As Shape
Private limit As Double
Private parent As Collection
Private message As String
Private nextCharBoxCreated As Boolean
Private Sub Class_Initialize()
    Set sh = Screen.Shapes.AddShape(msoShapeRectangle, 0, 0, 0, 0)
    sh.Visible = msoFalse
    sh.Line.Visible = msoFalse
    sh.Width = 50
    sh.Height = 50
    sh.Top = START_Y
    sh.Left = START_X
    sh.Fill.ForeColor.RGB = rgbWhite
    With sh.TextFrame2.TextRange.Font
        .Size = 36
        .NameComplexScript = "HGS行書体"
        .NameFarEast = "HGS行書体"
        .Name = "HGS行書体"
        .Fill.ForeColor.RGB = rgbWhite
    End With
    sh.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    sh.TextFrame2.VerticalAnchor = msoAnchorMiddle
    sh.Visible = msoTrue
    DoEvents
End Sub

Sub Init(c As Collection, limit_ As Double, message_ As String)
    limit = limit_
    message = message_
    Set parent = c
    c.Add Me, CStr(ObjPtr(Me))
    sh.TextFrame2.TextRange.Text = Left(message, 1)
End Sub

Function GetPercentage() As Double
    GetPercentage = (sh.Left - START_X) / (END_X - START_X)
End Function

Sub Move(amount)
    If IsMovable Then
        If GetPercentage < 0.5 Then
            n = 255 - CInt(255 * GetPercentage * 2)
        Else
            n = CInt(255 * (GetPercentage - 0.5) * 2)
        End If
        sh.Left = sh.Left + amount
        sh.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(n, n, n)
    Else
        parent.Remove CStr(ObjPtr(Me))
    End If
    
    If Not nextCharBoxCreated Then
        If sh.Left > START_X + sh.Width Then
            nextCharBoxCreated = True
            If Len(message) > 1 Then
                With New CharBox
                    .Init parent, limit, Mid(message, 2)
                End With
            End If
        End If
    End If
End Sub

Function IsMovable() As Boolean
    IsMovable = sh.Left < limit
End Function

Private Sub Class_Terminate()
    sh.Delete
End Sub

標準モジュール

モジュール名は任意。以下のコードを張り付ける。

Public Const START_X As Double = 20
Public Const START_Y As Double = 20
Public Const END_X As Double = 500

Sub HeartSutra()
    For Each sh In Screen.Shapes
        sh.Delete
    Next
    
    Dim c As Collection
    Set c = New Collection
    With New CharBox
        .Init c, END_X, Screen.Range("A1").Value
    End With
    
    Dim cb As CharBox
    Do While c.Count <> 0
        Application.ScreenUpdating = False
        For Each cb In c
            cb.Move 2
        Next
        Application.ScreenUpdating = True
        DoEvents
    Loop
    Debug.Print "End"
End Sub

実行方法

準備

Excelの表示タブで枠線を消しておく
Sheet1のモジュール名をScreenとしておく。
A1セルに般若心境を入力し、白文字にして見えなくしておく。

入力するのはこちら。

仏説摩訶般若波羅蜜多心経　　　　　観自在菩薩行深般若波羅蜜多時照見五蘊皆空度一切苦厄舎利子色不異空空不異色色即是空空即是色受想行識亦復如是舎利子是諸法空相不生不滅不垢不浄不増不減是故空中無色無受想行識無眼耳鼻舌身意無色声香味触法無眼界乃至無意識界無無明亦無無明尽乃至無老死亦無老死尽無苦集滅道無智亦無得以無所得故菩提薩埵依般若波羅蜜多故心無罣礙無罣礙故無有恐怖遠離一切顛倒夢想究竟涅槃三世諸仏依般若波羅蜜多故得阿耨多羅三藐三菩提故知般若波羅蜜多是大神呪是大明呪是無上呪是無等等呪能除一切苦真実不虚故説般若波羅蜜多呪即説呪曰羯諦羯諦波羅羯諦波羅僧羯諦菩提薩婆訶般若心経

※ちなみに埵と罣はShift-JISに無くて(多分日本の文字じゃない)、行書体が無いためその2文字だけ角ばったゴシック体になってしまう。

実行

HeartSutraを実行するだけ

解説

今回のコードはオートシェイプ1つに対して1つのオブジェクト(CharBox型)を対応付けて管理している。

CharBoxはコンストラクタでシェイプを作成する。
シェイプはSTART_Xに生成され、Move命令ごとに、END_Xに向かって移動する。
シェイプは移動距離が50%に達するまで、移動の度にフォントの色を徐々に濃くし、その後は100%に達するまで徐々に薄くする。
CharBoxはコンストラクタとは別のInitプロシージャでコレクションを受け取り、自身の格納アドレスをキーに自身をコレクションに登録する。一方でメインマクロはコレクションのみを保持しており、CharBoxは保持していない。したがってCharBoxはコレクションから消えると参照を失って消滅する仕組み。
CharBoxは、開始位置から自身の幅だけ進むと、次のCharBoxを生成する。ただし生成されたCharBoxが保持されるのはやはりコレクションのみで、CharBox同士に親子参照関係は無い。
CharBoxはEND_Xに達すると自身の格納アドレスをキーに自身をコレクションから抹消する。
参照を失ったCharBoxは消滅する。消滅の直前、デストラクタによりシェイプは削除される。