Some help needed with random values in Access

[magicalstone]

Hey guys,

I have a few problems with producing some random records in Access, help would be hugely appreciated!

The application is actually for a Lottery system, it's only a prototype and so it doesn't have to be flawless (i.e. I'm aware that random numbers made through Access isn't a good idea for a lottery with real money at stake).

Basically, I need to generate 3 new records in a table, and each record will be one of the balls 'drawn' for that week. Ok so here is the code as it is:

Private Sub Command0_Click()
Dim dbs As Database, rst As Recordset
Dim RandomNumber As Integer, i As Integer

'define the recordset
Set dbs = CurrentDb

'open the recordset
Set rst = dbs.OpenRecordset("tblDrawnBalls")

rst.AddNew
RandomNumber = 1 + Int(Rnd() * 9)
rst!DrawSelection = RandomNumber
rst!WeekID = 1
rst.Update

rst.AddNew
RandomNumber = 1 + Int(Rnd() * 9)
rst!DrawSelection = RandomNumber
rst!WeekID = 1
rst.Update

rst.AddNew
RandomNumber = 1 + Int(Rnd() * 9)
rst!DrawSelection = RandomNumber
rst!WeekID = 1
rst.Update


rst.Close
dbs.Close

MsgBox ("Done")
Beep
End Sub

The numbers need to be from 1 to 9, and this is fine. And this code is adding 3 new records, with a number from 1 to 9, and this is good.

BUT: I need the code to ensure that each number is different for each record, as obviously in a real lottery draw the same number could not be drawn twice in a draw. How can I edit my code to achieve this?

Finally, there is actually a further Field called 'STATUS' and this is a True/False field, and it will define which of the three balls is the bonus ball. So I need the code to randomly assign a TRUE status to the STATUS field for ONE of the records of the three for each draw. Is it possible to use VBA to achieve this too?

Any help will be hugely appreciated with these queries! Thank you

[X-BRichard-X]

This was a fun mini-project on which I worked for the magicalstone.

As you can imagine, there's a lot going on with this file which is why I opted to not only create a quick app with it using MS Access, but I also posted the code here.

The code has attributes that you won't see in a lot of VBA code because quite frankly, I'm not sure that many people know how to write code using the approaches I used.

I know the poster said that only a number from 1-9 would be used but I wanted to make things interesting. What if a 0 was needed? The way that the RNG in VBA is set up, you can't specify a range wherein the lowerbound is included which presumes that all ranges begin with 1. So, I opted to use a VBA Regular Expression to identify all numbers that were a base of 10 (having set the upper range to that number) then parsed through the long number to identify all instances of 10's within variables num1, num2, and num3 that would then be converted to 0s.

Using the regular expression's REPLACE method, I was able to easily convert all the 10s to 0s which normalized the 3 digit number which is what I did having earlier in the routine concatenated all the num variables.

While I didn't capture ALL the functionality that the poster was after, I did capture most of it. In any event, there is enough code written and commented out for an advanced VBA developer to understand.

As far as your bonus ball goes, you will have to ammend the code herein provided to achieve that objective.

By the way, the resulting table consists of automated dates and times to be filled in once the button is pressed to save a generated number. In addition, each number that is generated and saved is automatically date and time stamped based on the user's system clock setting.

I hope this solution makes sense. Here's the entire (87) lines of code used to provide this solution:

Option Compare Database
Option Explicit

Private Sub BtnExit_Click()
'Removes a number from the bingo text box and replaces it with a number whose record will
'be later identified then removed from the table
With Me.TxtBingoNbr
.SetFocus
.Locked = False
.Text = 1000
.Locked = True
End With
'Saves existing record and moves to a new record
DoCmd.GoToRecord acDataForm, "Main", acNewRec
With DoCmd
'Clean up table by removing all 1000-labeled records; these recs were not intended to be
'saved
.SetWarnings False
.OpenQuery "Delete Recs (1000) qry"
.SetWarnings True
End With
'Exit application
Application.Quit
End Sub

Private Sub BtnGenNbr_Click()
Dim Num1 As Byte
Dim Num2 As Byte
Dim Num3 As Byte
Dim BingoNum As Long
Me.TxtBingoNbr.Value = Null 'Remove any existing earlier bingo number
Randomize ' Initialize random number generator function - must have or your
' RNG will not work properly; this function generates the seed

Num1 = Int((10 * Rnd) + 1) 'Produces the first random number between 1 And 10. (10=0)
Num2 = Int((10 * Rnd) + 1) 'Produces the second random number between 1 And 10. (10=0)
Num3 = Int((10 * Rnd) + 1) 'Produces the third random number between 1 And 10. (10=0)
BingoNum = Num1 & Num2 & Num3
If BingoNum > 999 Then
'The RegExp Replace method is used to replace a part of a string that uses Regular
'Expresion matching
Dim InitialString As String
InitialString = BingoNum 'Convert the integer to a string
'Before declaring a new RegExp object, you must set a reference to the
'Microsoft VBScript Regular Expressions 5.5 library
Dim RegExMatch As New RegExp
With RegExMatch
.Pattern = "10" 'Old string value to replace
.IgnoreCase = True
.Global = True
End With
'The second argument represents the NEW string value to replace the old one
Me.TxtBingoNbr.Value = RegExMatch.Replace(BingoNum, "0") 'Add variable BingoNum to the text box
Set RegExMatch = Nothing
Else: Me.TxtBingoNbr.Value = BingoNum 'Add variable BingoNum to the text box
End If
End Sub

Private Sub BtnSaveRec_Click()
On Error GoTo FixIt
'Ensure that the existing record is not overwritten
DoCmd.GoToRecord acDataForm, "Main", acNext
Exit_Sub:
Exit Sub
FixIt:
Err.Clear
Resume Exit_Sub
Exit Sub
End Sub

Private Sub Form_Open(Cancel As Integer)
DoCmd.GoToRecord acDataForm, "Main", acNewRec
End Sub

[magicalstone]

This is clearly a very detailed response, and I more than appreciate the time and effort that has gone into producing this. However, I feel taht with my particular scenario the key problem is ensuring that the same number isn't drawn twice, and I cannot see how this code achieves this? I apologise if it does, and I am being completely blind to it.

[X-BRichard-X]

You are most welcome.

You are correct in your assessment of the solution in that it in fact does not generate unique numbers between 0 and 999. However, again, like the bonus ball requirement you had in your original posting, you will need to amend the code to achieve your functional objectives.

What I would suggest you do in terms of getting the functionality required to extract a unique number is to simply write code that calls a recordset from memory using ADO at the end of the BtnGenNbr_Click() subroutine to compare the original number generated to all the numbers currently listed in the data table.

This is not difficult to do to add to the existing solution and would require about (25) more lines of code.

What I provided was a framework in which your solution can be either amended or used as is.

It should be enough to get you started.

[DarkSprout]

Maybe the following will be a little easier to understand:


Public Function Random(Optional Lowerbound As Single, Optional Upperbound As Single, Optional WholeNumber As Boolean) As Single
'//Called by Bingo Function
Randomize
If (Lowerbound = 0) And (Upperbound = 0) Then
Random = Round(Rnd * 1, IIf(WholeNumber = False, 6, 0))
Else
Random = Round((Upperbound - Lowerbound + 1) * Rnd + Lowerbound, IIf(WholeNumber = False, 6, 0))
End If
End Function

Public Function Bingo() As Variant
'// Generates 3 Distinct Random Numbers, returned in a array
Dim strValues As String
Dim iLoop As Integer
Dim tmpRnd As String
Dim nArray() As String
For iLoop = 1 To 3
tmpRnd = ", " & Random(1, 9, True)
Do While InStr(1, strValues, tmpRnd, vbTextCompare) <> 0
tmpRnd = ", " & Random(1, 9, True)
Loop
strValues = strValues & tmpRnd
Next iLoop
strValues = "0" & strValues
nArray = Split(strValues, ",")
Bingo = nArray()
End Function

Public Function BingoTest(n As Integer) As Integer
'// THIS THIS FOR DEBUGING AND/OR TESTING,
'// OF NO VALUE TO THE BINGO FUNCTION AT ALL
'// i.e. in Immediate Window: ?BingoTest(2)

Dim BingoArray() As String
BingoArray = Bingo()

'// To get the value from the array use somthing like this or a loop:
'rst!DrawSelection = Val(BingoArray(1))

'// return a value from the test Function:
BingoTest = Val(BingoArray(n))
End Function


And Don't forget to:

Set rst = Nothing
Set dbs = Nothing


Enjoy,