VBA example - Microsoft Access: fortune teller program

To create a fortune teller program with Ms. Access 2007 as shown above, you need to open and Ms. Access 2007 application database and create a form and name it Frmfortuneteller. On this form, you will drop some textboxes, labels, and command buttons controls and design them as in the picture. You also need to create a table to store data. This table( TblFortuneTellerData) contains the number from 1 to 9(any person's number based on his/her name) and characteristics, personality, love, work and money for each number. After naming these controls (you may name them as used in the code below. Otherwise, it doesn't work), use the following code:

Option Compare Database
Option Explicit
'declaring variables
Dim Db As DAO.Database
Dim Rs As DAO.Recordset

Private Sub cmdCharacteristic_Click()
Call updatepos(1)
End Sub

Sub updatepos(f As Integer)
On Error GoTo ErrorTrack
Dim i As Integer
Rs.MoveFirst
For i = 0 To CInt(lblNumber.Caption) - 2
Rs.MoveNext
Next
txtView.Value = Rs(f).Value
ErrorTrack: Exit Sub
End Sub

Private Sub cmdLove_Click()
Call updatepos(3)
End Sub

Private Sub cmdMoney_Click()
Call updatepos(5)
End Sub

Private Sub cmdPersonality_Click()
Call updatepos(2)
End Sub

Private Sub cmdWork_Click()
Call updatepos(4)
End Sub

Private Sub Detail_Click()

End Sub

Private Sub Form_Load()
'create database object
Set Db = CurrentDb
Set Rs = Db.OpenRecordset("Select * From tblFortuneTellerData")
'lock navigation pane
DoCmd.LockNavigationPane (True)
End Sub

Private Sub Form_LostFocus()
'clear objects from memory
Rs.Close
Db.Close
Set Rs = Nothing
Set Db = Nothing
End Sub


Private Sub txtName_KeyPress(KeyAscii As Integer)
If (KeyAscii >= vbKey0 And KeyAscii <= vbKey9) Or Chr(KeyAscii) = "." Then
KeyAscii = 0
Else
Exit Sub
End If

End Sub

Private Sub txtName_LostFocus()
'translate name to number
If txtName.Value <> "" And Len(txtName.Value) <= 20 Then

Dim a(30) As Integer
Dim arr(30) As Integer
Dim i As Integer
Dim ch As String
Dim sum As Integer
sum = 0
Dim val As String
val = txtName.Value
For i = 0 To Len(val) - 1
ch = UCase(Right(Left(val, i + 1), 1))

If ch = "A" Or ch = "J" Or ch = "S" Then
a(i) = 1
ElseIf ch = "B" Or ch = "K" Or ch = "T" Then
a(i) = 2
ElseIf ch = "C" Or ch = "L" Or ch = "U" Then
a(i) = 3
ElseIf ch = "D" Or ch = "M" Or ch = "V" Then
a(i) = 4
ElseIf ch = "E" Or ch = "N" Or ch = "W" Then
a(i) = 5
ElseIf ch = "F" Or ch = "O" Or ch = "X" Then
a(i) = 6
ElseIf ch = "G" Or ch = "P" Or ch = "Y" Then
a(i) = 7
ElseIf ch = "H" Or ch = "Q" Or ch = "Z" Then
a(i) = 8
ElseIf ch = "I" Or ch = "R" Then
a(i) = 9
End If
Next
Dim j As Integer
Dim l As Integer
Dim m As Integer
Dim k As Integer
Dim sum1 As Integer
sum1 = 0
Dim arr1(30) As Integer

'Sum characters of numbers together to generate 1 character number
For j = 0 To Len(val) - 1
sum = sum + a(j)
Next

If Len(sum) >= 2 Then

For l = 1 To Len(sum)
arr(l - 1) = CInt(Right(Left(sum, l), 1))
Next
sum = 0
For m = 0 To UBound(arr) - 1
sum = sum + arr(m)
Next
End If

'Continue to sum characters of numbers together to generate 1 character number if sum is greater than 10

sum1 = Trim(sum)

If sum1 >= 10 Then
For l = 1 To Len(sum1)
arr1(l - 1) = CInt(Right(Left(sum1, l), 1))
Next
sum1 = 0
For m = 0 To UBound(arr1) - 1
sum1 = sum1 + arr1(m)
Next
End If

lblNumber.Caption = sum1
Else
'Alert one user tries to input too long text
MsgBox "Please Type your name in an acceptable length."

End If
End Sub