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

'クジがクリックされた
Public Sub ExShapeClick()
    Dim kname As String
    Dim tshape As Shape
    Dim nno As Long
    
    'クジの名前を取得
    kname = Application.Caller
    'クジ番号
    nno = Mid(kname, 5)
        
    For Each tshape In Sheets("くじ引き").Shapes
        '名前をチェック
        If tshape.name = kname Then
            '中央に移動
            ExMoveCenter tshape
            If atarikuji(nno) = 1 Then
                ExMakeClickShape True
            Else
                ExMakeClickShape False
            End If
            Exit For
        End If
    Next
    Set tshape = Nothing
End Sub

下記のVBAコードを追加してください。

Sub ExMakeClickShape(bsw As Boolean)
    Dim tshape As Shape
    Dim xc As Long
    Dim yc As Long
    Dim i As Integer
    
    'くじ描画範囲の中央位置を算出
    xc = (Sheets("くじ引き").Range("A1:K20").Width - 350) / 2
    yc = (Sheets("くじ引き").Range("A1:K20").Height - 350) / 2 + 50
    
    Set tshape = Sheets("くじ引き").Shapes.AddShape(Type:=msoShapeFlowchartDecision, Left:=xc, Top:=yc, Width:=350, Height:=350)

    '塗りつぶし
    tshape.Fill.Visible = True
    '透明度
    tshape.Fill.Transparency = 1
    '塗りつぶし色
    tshape.Fill.ForeColor.RGB = RGB(200, 249, 254)
    
    If bsw Then
        '文字をセット
        tshape.TextFrame.Characters.Text = "当たり"
    Else
        '文字をセット
        tshape.TextFrame.Characters.Text = "はずれ"
    End If
    
    '太字
    tshape.TextFrame.Characters.Font.Bold = True
    'サイズ
    tshape.TextFrame.Characters.Font.Size = 1
    '中央に表示
    tshape.TextFrame.HorizontalAlignment = xlCenter
    '中央に表示
    tshape.TextFrame.VerticalAlignment = xlCenter
    
    For i = 1 To 10
        '透明度
        tshape.Fill.Transparency = (10 - i) / 10
        'サイズ
        tshape.TextFrame.Characters.Font.Size = 2
        ExTimer 200
    Next
    
    If bsw Then
        '文字色
        tshape.TextFrame.Characters.Font.ColorIndex = 3
    Else
        '文字色
        tshape.TextFrame.Characters.Font.ColorIndex = 1
    End If
    
    For i = 1 To 13
        'サイズ
        tshape.TextFrame.Characters.Font.Size = i * 4
        ExTimer 200
    Next
    
    Set tshape = Nothing
End Sub