t-hom’s diary

主にVBAネタを扱っているブログです。

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

TwitterJavascriptを使った綺麗なアニメーションが流れてきたので、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

あとはBubbleAnimationを実行すればアニメーションが始まる。
終了方法は用意してないのでVBEの停止ボタンで止めている。

※今回のコードはお遊びなので割とやっつけコーディング。
 そのためマジックナンバーを多用してるが、良い子は真似しないように。

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。