Slot Machine help in VBA

[zkm1223]

Hi, I want to create a slot machine in VBA. I have managed to create a form with the 3 different pictures and a command button.

I have tried some code which I found on youtube, but it isn't working.

I want it to display messages when the user wins, i.e.:

Bronze, Bronze, Bronze = £5
Silver, Silver, Silver = £10
Gold, Gold, Gold = £50

Also I want it to be more likely to choose bronze over silver and gold.

Thanks in advance :)

[Zack Barresse]

Hi,

Not sure if this is what you're looking for, but it achieves the results. I used labels instead of images. Named them lblOne, lblTwo and lblThree. Their font size was set to 16 and their height 60. To keep it vertically in the center I added a chr(10) (i.e. Alt + Enter), just a quick fix. Here is the code...

Option Explicit

Private Const cBronze As Variant = &H8080&
Private Const cGold As Variant = &HFFFF&
Private Const cSilver As Variant = &HC0C0C0

Private Sub cmdStart_Click()

Const iInc As Long = 10
Const msDelay As Single = 0.1

Dim i As Long
Dim ii As Long
Dim iii As Long
Dim sRet As String
Dim iPrize As Long
Dim sPrize As String

For i = 1 To iInc
For ii = 1 To iInc
For iii = 1 To iInc
Call ChangeColor(Me.lblOne)
Call ChangeColor(Me.lblTwo)
Call ChangeColor(Me.lblThree)
Next iii
Call ChangeColor(Me.lblOne)
Call ChangeColor(Me.lblTwo)
Call ChangeColor(Me.lblThree)
Next ii
Call ChangeColor(Me.lblOne)
Call ChangeColor(Me.lblTwo)
Call ChangeColor(Me.lblThree)
Next i

'Get results
sRet = vbNullString
Select Case WorksheetFunction.Clean(Me.lblOne.Caption)
Case "Bronze": sRet = sRet & "B"
Case "Silver": sRet = sRet & "S"
Case "Gold": sRet = sRet & "G"
End Select
Select Case WorksheetFunction.Clean(Me.lblTwo.Caption)
Case "Bronze": sRet = sRet & "B"
Case "Silver": sRet = sRet & "S"
Case "Gold": sRet = sRet & "G"
End Select
Select Case WorksheetFunction.Clean(Me.lblThree.Caption)
Case "Bronze": sRet = sRet & "B"
Case "Silver": sRet = sRet & "S"
Case "Gold": sRet = sRet & "G"
End Select

'Check results
Select Case sRet
'all bronze
Case "BBB": iPrize = 5
'2 bronze, 1 silver
Case "BBS": iPrize = 6
Case "BSB": iPrize = 6
Case "SBB": iPrize = 6
'2 bronze, 1 gold
Case "BBG": iPrize = 7
Case "BGB": iPrize = 7
Case "GBB": iPrize = 7
'2 silver, 1 bronze
Case "BSS": iPrize = 8
Case "SSB": iPrize = 8
Case "SBS": iPrize = 8
'2 silver, one gold
Case "SSG": iPrize = 9
Case "GSS": iPrize = 9
Case "SGS": iPrize = 9
'all silver
Case "SSS": iPrize = 10
'1 of each
Case "GSB": iPrize = 15
Case "GBS": iPrize = 15
Case "BGS": iPrize = 15
Case "BSG": iPrize = 15
Case "SBG": iPrize = 15
Case "SGB": iPrize = 15
'2 gold, 1 bronze
Case "BGG": iPrize = 30
Case "GGB": iPrize = 30
Case "GBG": iPrize = 30
'2 gold, 1 silver
Case "GGS": iPrize = 40
Case "GSG": iPrize = 40
Case "SGG": iPrize = 40
'all gold
Case "GGG": iPrize = 50

End Select

MsgBox "You won " & iPrize & " of something!", vbExclamation, "CONGRATS!"

End Sub

Private Sub ChangeColor(lblCtrl As MSForms.Label)
Dim iRandom As Long
iRandom = WorksheetFunction.RandBetween(1, 1000)
Select Case iRandom
Case Is <= 500 '50%
lblCtrl.Caption = Chr(10) & "Bronze"
lblCtrl.BackColor = cBronze
Case Is <= 800 '30%
lblCtrl.Caption = Chr(10) & "Silver"
lblCtrl.BackColor = cSilver
Case Else '20%
lblCtrl.Caption = Chr(10) & "Gold"
lblCtrl.BackColor = cGold
End Select
End Sub

HTH

[zkm1223]

Yes thank you very much :) The only winning options were BBB, SSS and GGG. I changed the others to 0 so it works fine.

Also do you know how the user can keep a record of the last 10 attempts at the slot machine in a table showing the date/ time, what the results were and if they won anything?

[zkm1223]

here is my file:

[Zack Barresse]

I don't have a previous version to test with, so this should work in 2007 and beyond. I put a conditional compilation with code I think should work in previous versions. Let us know if it works.
Option Explicit

Private Const cBronze As Variant = &H8080&
Private Const cGold As Variant = &HFFFF&
Private Const cSilver As Variant = &HC0C0C0

Dim iVersion As Long

Private Sub cmdStart_Click()

Const iInc As Long = 10
Const msDelay As Single = 0.1

Dim i As Long
Dim ii As Long
Dim iii As Long
Dim sRet As String
Dim iPrize As Long
Dim sPrize As String
Dim iLastRow As Long

For i = 1 To iInc
For ii = 1 To iInc
For iii = 1 To iInc
Call ChangeColor(Me.lblOne)
Call ChangeColor(Me.lblTwo)
Call ChangeColor(Me.lblThree)
Next iii
Call ChangeColor(Me.lblOne)
Call ChangeColor(Me.lblTwo)
Call ChangeColor(Me.lblThree)
Next ii
Call ChangeColor(Me.lblOne)
Call ChangeColor(Me.lblTwo)
Call ChangeColor(Me.lblThree)
Next i

'Get results
sRet = vbNullString
Select Case WorksheetFunction.Clean(Me.lblOne.Caption)
Case "Bronze": sRet = sRet & "B"
Case "Silver": sRet = sRet & "S"
Case "Gold": sRet = sRet & "G"
End Select
Select Case WorksheetFunction.Clean(Me.lblTwo.Caption)
Case "Bronze": sRet = sRet & "B"
Case "Silver": sRet = sRet & "S"
Case "Gold": sRet = sRet & "G"
End Select
Select Case WorksheetFunction.Clean(Me.lblThree.Caption)
Case "Bronze": sRet = sRet & "B"
Case "Silver": sRet = sRet & "S"
Case "Gold": sRet = sRet & "G"
End Select

'Check results
Select Case sRet
'all bronze
Case "BBB": iPrize = 5
'2 bronze, 1 silver
Case "BBS": iPrize = 0
Case "BSB": iPrize = 0
Case "SBB": iPrize = 0
'2 bronze, 1 gold
Case "BBG": iPrize = 0
Case "BGB": iPrize = 0
Case "GBB": iPrize = 0
'2 silver, 1 bronze
Case "BSS": iPrize = 0
Case "SSB": iPrize = 0
Case "SBS": iPrize = 0
'2 silver, one gold
Case "SSG": iPrize = 0
Case "GSS": iPrize = 0
Case "SGS": iPrize = 0
'all silver
Case "SSS": iPrize = 10
'1 of each
Case "GSB": iPrize = 0
Case "GBS": iPrize = 0
Case "BGS": iPrize = 0
Case "BSG": iPrize = 0
Case "SBG": iPrize = 0
Case "SGB": iPrize = 0
'2 gold, 1 bronze
Case "BGG": iPrize = 0
Case "GGB": iPrize = 0
Case "GBG": iPrize = 0
'2 gold, 1 silver
Case "GGS": iPrize = 0
Case "GSG": iPrize = 0
Case "SGG": iPrize = 0
'all gold
Case "GGG": iPrize = 50

End Select

If iPrize > 0 Then
'append to table
With ThisWorkbook.Worksheets("Sheet1")
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(iLastRow, 1).Value = VBA.Date()
.Cells(iLastRow, 2).Value = VBA.Time()
.Cells(iLastRow, 3).Value = WorksheetFunction.Clean(Me.lblOne.Caption)
.Cells(iLastRow, 4).Value = WorksheetFunction.Clean(Me.lblTwo.Caption)
.Cells(iLastRow, 5).Value = WorksheetFunction.Clean(Me.lblThree.Caption)
.Cells(iLastRow, 6).Value = iPrize

iVersion = CLng(Application.Version)
#If iVersion >= 12 Then
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("A2:A" & iLastRow), Order:=xlDescending
.Sort.SortFields.Add Key:=.Range("B2:B" & iLastRow), Order:=xlDescending
.Sort.SetRange Range("A1:F" & iLastRow)
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.Apply
#Else
.Range("A1:F" & iLastRow).Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Key2:=.Range("B1"), Order1:=xlAscending, _
Header:=xlYes
#End If

'/// OPTIONAL TO ONLY KEEP TEN RECORDS (DELETE EARLIEST ENTRY)
.Range("12:" & iLastRow).Delete

End With
End If

MsgBox "You won " & iPrize & " pounds!", vbExclamation, "CONGRATS!"

End Sub

Private Sub ChangeColor(lblCtrl As MSForms.Label)
Dim iRandom As Long
iRandom = WorksheetFunction.RandBetween(1, 1000)
Select Case iRandom
Case Is <= 500 '50%
lblCtrl.Caption = Chr(10) & "Bronze"
lblCtrl.BackColor = cBronze
Case Is <= 800 '30%
lblCtrl.Caption = Chr(10) & "Silver"
lblCtrl.BackColor = cSilver
Case Else '20%
lblCtrl.Caption = Chr(10) & "Gold"
lblCtrl.BackColor = cGold
End Select
End Sub
HTH

[zkm1223]

hi, thanks for the reply. I have used the code you have given, it shows a tables with the date, time etc. but none of the results are recorded in it.

I wanted the table to record the 10 latest attempts at the slot machine.