VBA オートシェイプを使った泡のアニメーション

TwitterでJavascriptを使った綺麗なアニメーションが流れてきたので、VBAでも真似してみた。
ics.media

本家の躍動感まではコピーできなかったけど、それなりに見栄えのするアニメーションができたので紹介。

f:id:t-hom:20180830223613g:plain

作り方

まずSheet1のオブジェクト名をプロパティウィンドウからScreenに変更する。
f:id:t-hom:20180830223828p:plain

そしてシートモジュールScreenのコードに初期化用のClearプロシージャを用意しておく。

Sub Clear()
    Me.Cells.Interior.Color = vbBlack
    Dim sh As Shape
    For Each sh In Me.Shapes
        sh.Delete
    Next
End Sub

次にクラスモジュールを挿入し、オブジェクト名をBubbleとする。

クラスのコードはこちら。

Option Explicit
Private bubbleShape As Shape
Private speed As Double
Private scales As Double

Public Function Float() As Boolean
    If bubbleShape.Top - speed > 0 Then
        bubbleShape.IncrementTop -speed
        speed = speed * 1.1
        scales = scales * 0.99
        bubbleShape.ScaleHeight scales, msoFalse, msoScaleFromMiddle
        bubbleShape.ScaleWidth scales, msoFalse, msoScaleFromMiddle
        Dim c: c = Int((255 - 100 + 1) * Rnd + 100)
        bubbleShape.Fill.ForeColor.RGB = RGB(c, c, c)
        Float = True
    Else
        Float = False
    End If
End Function

Private Sub Class_Initialize()
    Randomize
    speed = 5
    scales = 1
    
    Dim x: x = Int((Application.Width - 0 + 1) * Rnd + 0)
    Dim y: y = Int((Application.Height - 200 + 1) * Rnd + 200)
    Dim size: size = Int((50 - 30 + 1) * Rnd + 30)
    If Int((1 - 0 + 1) * Rnd + 0) = 1 Then
        Set bubbleShape = Screen.Shapes.AddShape(msoShapeDonut, x, y, size, size)
        bubbleShape.Adjustments.Item(1) = 0.1
    Else
        Set bubbleShape = Screen.Shapes.AddShape(msoShapeOval, x, y, size, size)
    End If
    bubbleShape.Line.Visible = msoFalse
    bubbleShape.Fill.ForeColor.RGB = vbWhite
    bubbleShape.Fill.Transparency = 0.1
End Sub

Public Property Get Self() As Object
    Set Self = Me
End Property

Private Sub Class_Terminate()
    bubbleShape.Delete
End Sub

最後にメインプロシージャ用に標準モジュールを挿入する。
このモジュールのオブジェクト名は任意。

標準モジュールに書くコードはこちら。

Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If
Sub BubbleAnimation()
    Const BUBBLE_LEVEL = 5 ' 1 to 10
    Screen.Clear
    Dim bubbles As Collection: Set bubbles = New Collection
    Do
        Application.ScreenUpdating = False
        Dim i
        For i = 1 To Int((BUBBLE_LEVEL - 0 + 1) * Rnd + 0)
            bubbles.Add New Bubble
        Next
        
        Dim j
        For j = bubbles.Count To 1 Step -1
            If Not bubbles(j).Float Then
                bubbles.Remove j
            End If
        Next
        Application.ScreenUpdating = True
        Sleep 10
        DoEvents
    Loop
End Sub