VBA example - Microsoft Access : fortune teller program

Fortune teller program

Access 2007 Fortune Teller

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
For i = 0 To CInt(lblNumber.Caption) - 2
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
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
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
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)

If Len(sum) >= 2 Then

For l = 1 To Len(sum)
arr(l - 1) = CInt(Right(Left(sum, l), 1))
sum = 0
For m = 0 To UBound(arr) - 1
sum = sum + arr(m)
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))
sum1 = 0
For m = 0 To UBound(arr1) - 1
sum1 = sum1 + arr1(m)
End If

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

End If
End Sub


This website intents to provide free and high quality tutorials, examples, exercises and solutions, questions and answers of programming and scripting languages:
C, C++, C#, Java, VB.NET, Python, VBA,PHP & Mysql, SQL, JSP, ASP.NET,HTML, CSS, JQuery, JavaScript and other applications such as MS Excel, MS Access, and MS Word. However, we don't guarantee all things of the web are accurate. If you find any error, please report it then we will take actions to correct it as soon as possible.