Excelで三角くじを作ってみよう

Option Explicit

'Windowsが起動してからの経過時間 API
Private Declare Function GetTickCount Lib "kernel32" () As Long

'タイマー
Private Sub ExTimer(tim As Long)
    Dim st As Long
    
    '開始時間を取得
    st = GetTickCount
    DoEvents
    Do
        If GetTickCount - st >= tim Then
            '時間が経過した
            Exit Do
        End If
        DoEvents
    Loop
End Sub

'中央に移動
Private Sub ExMoveCenter(tshape As Shape)
    Dim xc As Long
    Dim yc As Long
    Dim i As Long
    Dim xf As Double
    Dim yf As Double
    
    'くじ描画範囲の中央位置を算出
    xc = (Sheets("くじ引き").Range("A1:K20").Width - tshape.Width) / 2
    yc = (Sheets("くじ引き").Range("A1:K20").Height - tshape.Height) / 2
    xf = (xc - tshape.Left) / 50
    yf = (yc - tshape.Top) / 50
    For i = 1 To 50
        tshape.Left = tshape.Left + xf
        tshape.Top = tshape.Top + yf
        '回転させる
        tshape.IncrementRotation 10
        'タイマー
        ExTimer 10
    Next
    '削除
    tshape.Delete
End Sub

Public Sub ExShapeClick()
    Dim kname As String
    Dim tshape As Shape
    
    'クジの名前を取得
    kname = Application.Caller
    Range("A1") = kname
    'クジ番号
    Range("A2") = Mid(kname, 5)
    
    For Each tshape In Sheets("くじ引き").Shapes
        '名前をチェック
        If tshape.name = kname Then
            '中央に移動
            ExMoveCenter tshape
            Exit For
        End If
    Next
    Set tshape = Nothing
End Sub