当サイトではアフィリエイトプログラムを利用して商品を紹介しています。

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

【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. あとりえこばと より:

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

タイトルとURLをコピーしました