【Excel；VBA】ROULETTE for Excel 〜人生は博打だ！ コード・プログラム
【コード・プログラム】
Sub RunRoulette()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim btn As Button, arrow As Shape
Dim centerX As Single, centerY As Single, radius As Single
Dim i As Integer, angle As Double, sliceCount As Integer
Dim shp As Shape, txt As Shape
Dim theta As Double, textX As Single, textY As Single
' 初期化
For Each shp In ws.Shapes
If shp.Name Like "Slice*" Or shp.Name Like "Num*" Or shp.Name = "btnStart" Or shp.Name = "Arrow" Then
shp.Delete
End If
Next shp
' 中心座標と半径
centerX = 200: centerY = 200: radius = 100
sliceCount = 12
angle = 360 / sliceCount
' STARTボタン
Set btn = ws.Buttons.Add(350, 100, 80, 30)
With btn
.OnAction = "SpinRoulette"
.Caption = "START"
.Name = "btnStart"
End With
' ▼マーク（255度方向に配置＝5時と6時の間）
Dim arrowAngle As Double: arrowAngle = 255 * WorksheetFunction.Pi() / 180
Dim arrowX As Single, arrowY As Single
arrowX = centerX + 0.9 * radius * Cos(arrowAngle)
arrowY = centerY - 0.9 * radius * Sin(arrowAngle)
Set arrow = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, arrowX - 10, arrowY - 10, 20, 20)
With arrow
.TextFrame2.TextRange.Text = "▲"
.TextFrame2.HorizontalAnchor = msoAnchorCenter
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.Font.Size = 14
.TextFrame2.TextRange.Font.Bold = msoTrue
.TextFrame2.TextRange.Font.Name = "Arial"
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
.Name = "Arrow"
End With
' ルーレット描画
For i = 0 To sliceCount - 1
Set shp = ws.Shapes.AddShape(msoShapePie, centerX - radius, centerY - radius, radius * 2, radius * 2)
With shp
.Adjustments.Item(1) = i * angle
.Adjustments.Item(2) = (i + 1) * angle
.Fill.ForeColor.RGB = IIf(i Mod 2 = 0, RGB(255, 0, 0), RGB(0, 0, 0))
.Line.ForeColor.RGB = RGB(255, 255, 255)
.Name = "Slice" & i
End With
theta = (i + 0.5) * angle * WorksheetFunction.Pi() / 180
textX = centerX + 0.65 * radius * Cos(theta)
textY = centerY + 0.65 * radius * Sin(theta)
Set txt = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, textX - 18, textY - 14, 36, 28)
With txt
.TextFrame2.TextRange.Text = CStr(i)
.TextFrame2.HorizontalAnchor = msoAnchorCenter
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.Font.Name = "Arial"
.TextFrame2.TextRange.Font.Size = IIf(i >= 10, 12, 16)
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = IIf(i Mod 2 = 0, RGB(0, 0, 0), RGB(255, 255, 255))
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
.Name = "Num" & i
End With
Next i
End Sub
Sub SpinRoulette()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim i As Integer, j As Integer, sliceCount As Integer
Dim delay As Double
Dim resultIndex As Integer
Dim tempText() As String, tempColor() As Long
Dim spinCount As Integer
Dim arrowIndex As Integer
sliceCount = 12
ReDim tempText(0 To sliceCount - 1)
ReDim tempColor(0 To sliceCount - 1)
' 数字と色を保存
For i = 0 To sliceCount - 1
tempText(i) = ws.Shapes("Num" & i).TextFrame2.TextRange.Text
tempColor(i) = IIf(i Mod 2 = 0, RGB(255, 0, 0), RGB(0, 0, 0))
Next i
' ランダムな回転数（40～79回転）
Randomize
spinCount = Int(Rnd() * 40) + 40
' 回転アニメーション（数字＋色）
For j = 1 To spinCount
For i = 0 To sliceCount - 1
ws.Shapes("Num" & i).TextFrame2.TextRange.Text = tempText((i + j) Mod sliceCount)
ws.Shapes("Slice" & i).Fill.ForeColor.RGB = tempColor((i + j) Mod sliceCount)
ws.Shapes("Num" & i).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = _
IIf(tempColor((i + j) Mod sliceCount) = RGB(255, 0, 0), RGB(0, 0, 0), RGB(255, 255, 255))
Next i
DoEvents
delay = 0.02 + 0.002 * j
Application.Wait Now + TimeSerial(0, 0, delay)
Next j
' ▼の位置（255度）に来た数字を当たりにする
arrowIndex = 9
resultIndex = (spinCount + arrowIndex) Mod sliceCount
MsgBox "★当たりは「" & tempText(resultIndex) & "」です！", vbInformation
End Sub
【実際に動作してるところの動画】
https://youtube.com/shorts/l-xORxwmxFI?si=l9ncuf7Eg5v5LLJq
