『Excel VBA 表計算とプログラミング学習サイト』では、アフィリエイトプログラムを利用して商品を紹介しています。

【VBA】Waitメソッドでアニメーション

2017.10.21

【VBA】Waitメソッドの機能を使ってアニメーションを作ります

この記事では、VBA のセルに色塗りする機能と Waitメソッド を使って簡単なアニメーションを作ってみます。コードはとっても簡単です。

'[VBA] Waitメソッドでブロック落とし(1)

Sub Drop_Cell_1()

　　Dim i As Integer

　　For i = 1 To 9
　　　　'背景色をクリア
　　　　Cells(i, 2).Interior.ColorIndex = 0
　　　　'背景色を赤に塗る
　　　　Cells(i + 1, 2).Interior.ColorIndex = 3
　　　　'次の処理まで1秒待つ
　　　　Application.Wait (Now + TimeValue("0:00:01"))
　　Next i

End Sub

Drop_Cell_1 を実行すると赤いセルがブロックみたいに下に落ちて行きます。
 
WaitメソッドでVBAブロックアニメーション
 
Drop_Cell_1 が何をしているのかというと、
 
　① セル A1 の背景色をクリアする
　② セル A2 を赤く塗る
　③ セル A2 の背景色をクリアする
　④ セル A3 を赤く塗る
　⑤ セル A3 の背景色をクリアする
 
てことを繰り返しているだけなのです。でも普通に For…Next で実行させると目にも止まらぬ速さで処理してしまうので、何が起こったのかわらないうちに終わってしまいます。そんな高速アニメーションを目で追うなんて、一生懸命忍術の修業をしなくては無理です（意味不明）。でも忍術修業より VBA 修業のほうが簡単ですよ。たぶん。てことで、

Application.Wait [Now() + "0:00:01"]

という一文で処理を敢えて遅くしておきましょう。Applicationオブジェクトに対して Waitメソッドを使用すると、指定時間まで処理を一時停止 しておけるのです。Now関数で現在のシステム日付と時刻を得て、それに 1 秒を加えています。つまり「次の処理に移るまで 1 秒待ちなさい」という命令を与えているのです。

ところで、Drop_Cell_1() を実行してみると「ちょっと動きが遅いな」と感じるかもしれません。アニメーションで 1 秒はかなり長く感じる間隔です。てことで、待ち時間を 0.5 秒間隔にしてみましょう。

'[VBA] Waitメソッドでブロック落とし(2)

Sub Drop_Cell_2()

　　Dim i As Integer

　　For i = 1 To 9
　　　　'背景色をクリア
　　　　Cells(i, 2).Interior.ColorIndex = 0
　　　　'背景色を赤に塗る
　　　　Cells(i + 1, 2).Interior.ColorIndex = 3
　　　　'次の処理まで0.5秒待つ
　　　　Application.Wait [Now() + "0:00:00.5"]
　　Next i

End Sub

Waitメソッド の引数の中で加える時間を

"0:00:00.5"

のように指定してあります。これがコンマ 5 秒を表す書き方です。最小でミリ秒まで指定できます。これを応用すると「テトリス」みたいなゲームが作れるかもしれません … たぶん …. 作ったことないからわからないけど。
 
次はブロックがあちこち動き回るプログラムを作ってみましょう。

'[VBA] ブロックをぐるぐる動かすマクロ

Sub Cell_Animation()

　　Dim i As Integer
　　Dim j As Integer
　　Dim ct As Integer
　　Dim rd As Integer

　　Randomize

　　i = 10
　　j = 10

　　For ct = 1 To 30

　　　　'1から4の乱数を作る
　　　　rd = Int(RND * 4 + 1)
　　　　Cells(i, j).Interior.ColorIndex = 0

　　　　Select Case rd
　　　　　　Case 1
　　　　　　　　i = i + 1
　　　　　　Case 2
　　　　　　　　i = i - 1
　　　　　　Case 3
　　　　　　　　j = j + 1
　　　　　　Case Else
　　　　　　　　j = j - 1
　　　　End Select

　　　　'端に来たら戻す
　　　　If i <= 0 Then
　　　　　　i = i + 1
　　　　End If

　　　　If j <= 0 Then
　　　　　　j = j + 1
　　　　End If

　　　　Cells(i, j).Interior.ColorIndex = 3

　　　　'次の処理まで0.5秒待つ
　　　　Application.Wait [Now() + "0:00:00.5"]

　　Next ct

End Sub

Rnd関数で乱数を発生させて、色を塗るセルをランダムに移動させているのです。Cell_Animation() を実行すると、ブロック（セル）がぐるぐる動き回ります。面白いのでぜひ試してみてね。それではまた次回お会いしましょう。

コメント

  1. あとりえこばと より:
    2023年4月27日 8:01 PM

    [K] ChatGPTにアニメーション・マクロを作ってもらいました。
     
    [Q] ワークシート上に1秒間に1回転する三角形を描くマクロを作ってください。
     
    [ChatGPT] 以下は、ワークシート上に1秒間に1回転する三角形を描くVBAマクロの例です。三角形は、セルB2を中心として回転します。

    Sub RotateTriangle()
    Dim angle As Single
    Dim x1 As Single, y1 As Single
    Dim x2 As Single, y2 As Single
    Dim x3 As Single, y3 As Single
    Dim centerX As Single, centerY As Single
    Dim radius As Single
    
    ' 三角形の頂点の座標を設定する
    x1 = 0: y1 = -10
    x2 = -10: y2 = 10
    x3 = 10: y3 = 10
    
    ' 中心点の座標と半径を設定する
    centerX = Range("B2").Left + Range("B2").Width / 2
    centerY = Range("B2").Top + Range("B2").Height / 2
    radius = 30
    
    ' 時計回りに回転する
    For angle = 0 To 360 Step 6 ' 1秒間に6度回転する
        ' 三角形を回転させる
        RotatePoint x1, y1, centerX, centerY, angle
        RotatePoint x2, y2, centerX, centerY, angle
        RotatePoint x3, y3, centerX, centerY, angle
        
        ' 三角形を描く
        With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
            .Line.Visible = msoTrue
            .Line.ForeColor.RGB = RGB(255, 0, 0)
            .Name = "Line1"
        End With
        With ActiveSheet.Shapes.AddLine(x2, y2, x3, y3)
            .Line.Visible = msoTrue
            .Line.ForeColor.RGB = RGB(255, 0, 0)
            .Name = "Line2"
        End With
        With ActiveSheet.Shapes.AddLine(x3, y3, x1, y1)
            .Line.Visible = msoTrue
            .Line.ForeColor.RGB = RGB(255, 0, 0)
            .Name = "Line3"
        End With
        
        ' 0.1秒待機する
        Application.Wait Now + TimeValue("0:00:0.1")
        
        ' 三角形を消去する
        ActiveSheet.Shapes.Range(Array("Line1", "Line2", "Line3")).Delete
    Next angle
End Sub

    　
    指定した座標を中心として指定した角度だけ回転させるサブルーチン

    Sub RotatePoint(ByRef x As Single, ByRef y As Single, ByVal centerX As Single, ByVal centerY As Single, ByVal angle As Single)
    Dim radians As Single
    radians = angle * WorksheetFunction.Pi / 180 ' 角度をラジアンに変換する
    Dim cosA As Single, sinA As Single
    cosA = Cos(radians)
    sinA = Sin(radians)
    Dim newX As Single, newY As Single
    newX = (x - centerX) * cosA - (y - centerY) * sinA + centerX
    newY = (x - centerX)

    　
    [K] 実行してみると、処理が重すぎてフリーズしました … アニメーションのような複雑なコードを書いてもらう時は、もう少し細かい指示が必要かもしれません。

    返信