VB 6.0 Simple Data Entry

Option Explicit
Dim rsEMPINFO As ADODB.Recordset
Dim rsSALARYGRADE As ADODB.Recordset

Private Sub cmdAdd_Click()
Picture1.Visible = False
InitMemVars
Frame1.Enabled = True
Frame1.Caption = "ADD"
End Sub

Private Sub cmdCancel_Click()
Picture1.Visible = True
Frame1.Enabled = False
Frame1.Caption = ""
StoreMemVars
End Sub

Private Sub cmdDelete_Click()
If MsgBox("Delete this record? Are you sure?", vbQuestion + vbYesNo, "Delete Record...") = vbYes Then
PPISconn.Execute ("Delete * from EMPINFO Where ID = " & labID.Caption)
rsRefresh
StoreMemVars
End If
End Sub

Private Sub cmdEdit_Click()
Picture1.Visible = False
Frame1.Enabled = True
Frame1.Caption = "EDIT"
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdFind_Click()
On Error GoTo ErrorFind
Dim ToFind As String
ToFind = InputBox("Input Employee LastName to find...", "Find")
If Trim(ToFind) <> "" Then
Dim rsEMPINFO_CLONE As ADODB.Recordset
Set rsEMPINFO_CLONE = New ADODB.Recordset
Set rsEMPINFO_CLONE = rsEMPINFO.Clone
rsEMPINFO_CLONE.Find "LastName Like '" & ToFind & "%'"
If Not rsEMPINFO_CLONE.EOF Then
rsEMPINFO.Bookmark = rsEMPINFO_CLONE.Bookmark
StoreMemVars
Else
MsgBox "Cannot find " & ToFind
End If
End If
Exit Sub

ErrorFind:
MsgBox "Error: " & Err.Description, vbCritical, "Error in Find"
End Sub

Private Sub cmdNext_Click()
rsEMPINFO.MoveNext
If rsEMPINFO.EOF Then
rsEMPINFO.MoveLast
MsgBox "Last Record!", vbInformation, "Info"
End If
StoreMemVars
End Sub

Private Sub cmdPrev_Click()
rsEMPINFO.MovePrevious
If rsEMPINFO.BOF Then
rsEMPINFO.MoveFirst
MsgBox "First Record!", vbInformation, "Info"
End If
StoreMemVars
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrorOnSave
Screen.MousePointer = 11
If Frame1.Caption = "ADD" Then
PPISconn.Execute ("Insert Into EMPINFO " & _
"(LastName,FirstName,MiddleName,Address,BirthDate" & _
",EmpNo,Position,DateHired,SalaryGrade)" & _
" values (" & String2Null(txtLastName.Text) & "," & String2Null(txtFirstName.Text) & _
"," & String2Null(txtMiddleName.Text) & "," & String2Null(txtAddress.Text) & _
"," & String2Null(txtBirthDate.Text) & "," & String2Null(txtEmpNo.Text) & _
"," & String2Null(txtPosition.Text) & "," & String2Null(txtDateHired.Text) & "," & String2Null(SetSalaryCode(cboSalaryGrade.Text)))
Else
PPISconn.Execute ("Update EMPINFO set" & _
" Lastname = " & String2Null(txtLastName.Text) & "," & _
" Firstname = " & String2Null(txtFirstName.Text) & "," & _
" Middlename = " & String2Null(txtMiddleName.Text) & "," & _
" Address = " & String2Null(txtAddress.Text) & "," & _
" birthdate = " & String2Null(txtBirthDate.Text) & "," & _
" EmpNo = " & String2Null(txtEmpNo.Text) & "," & _
" position = " & String2Null(txtPosition.Text) & "," & _
" dateHired = " & String2Null(txtDateHired.Text) & "," & _
" SalaryGrade = " & String2Null(SetSalaryCode(cboSalaryGrade.Text)) & _
" Where ID = " & labID.Caption)
End If
rsRefresh
rsEMPINFO.Find "EMPNO = " & String2Null(txtEmpNo.Text)
cmdCancel.Value = True
Screen.MousePointer = 0
Exit Sub


ErrorOnSave:
Screen.MousePointer = 0
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Error Encountered"
Exit Sub
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then
SendKeys "{TAB}"
End If
End Sub

Private Sub Form_Load()
CenterMe Me
Frame1.Enabled = False
Frame1.Caption = ""
rsRefresh
StoreMemVars
End Sub

Sub rsRefresh()
Set rsEMPINFO = New ADODB.Recordset
rsEMPINFO.Open "Select * from EMPINFO Order by Lastname,FirstName,MiddleName asc", PPISconn, adOpenKeyset
End Sub

Sub InitMemVars()
txtLastName.Text = ""
txtFirstName.Text = ""
txtMiddleName.Text = ""
txtAddress.Text = ""
txtBirthDate.Text = ""
txtEmpNo.Text = ""
txtPosition.Text = ""
txtDateHired.Text = ""
InitCbo
End Sub

Sub InitCbo()
Set rsSALARYGRADE = New ADODB.Recordset
Set rsSALARYGRADE = PPISconn.Execute("Select * from SALARY_GRADE order by SGCODE asc")
If Not rsSALARYGRADE.EOF And Not rsSALARYGRADE.BOF Then
rsSALARYGRADE.MoveFirst
Do While Not rsSALARYGRADE.EOF
cboSalaryGrade.AddItem Null2string(rsSALARYGRADE!Description)
rsSALARYGRADE.MoveNext
Loop
End If
Set rsSALARYGRADE = Nothing
End Sub

Function SetSalaryDescription(XXX As String) As String
Set rsSALARYGRADE = New ADODB.Recordset
Set rsSALARYGRADE = PPISconn.Execute("Select * from SALARY_GRADE Where SGCODE = " & String2Null(XXX))
If Not rsSALARYGRADE.EOF And Not rsSALARYGRADE.BOF Then
SetSalaryDescription = Null2string(rsSALARYGRADE!Description)
End If
Set rsSALARYGRADE = Nothing
End Function

Function SetSalaryCode(XXX As String) As String
Set rsSALARYGRADE = New ADODB.Recordset
Set rsSALARYGRADE = PPISconn.Execute("Select * from SALARY_GRADE Where DESCRIPTION = " & String2Null(XXX))
If Not rsSALARYGRADE.EOF And Not rsSALARYGRADE.BOF Then
SetSalaryCode = Null2string(rsSALARYGRADE!SGCode)
End If
Set rsSALARYGRADE = Nothing
End Function

Sub StoreMemVars()
If Not rsEMPINFO.EOF And Not rsEMPINFO.BOF Then
labID.Caption = rsEMPINFO!ID
txtLastName.Text = Null2string(rsEMPINFO!LastName)
txtFirstName.Text = Null2string(rsEMPINFO!FirstName)
txtMiddleName.Text = Null2string(rsEMPINFO!MiddleName)
txtAddress.Text = Null2string(rsEMPINFO!Address)
txtBirthDate.Text = Null2string(rsEMPINFO!BirthDate)
txtEmpNo.Text = Null2string(rsEMPINFO!EmpNo)
txtPosition.Text = Null2string(rsEMPINFO!Position)
txtDateHired.Text = Null2string(rsEMPINFO!DateHired)
cboSalaryGrade.Text = SetSalaryDescription(Null2string(rsEMPINFO!salarygrade))
Else
MsgBox "No Such Record!", vbInformation, "No Data..."
End If
End Sub

'ModMain

Option Explicit
Public PPISconn As ADODB.Connection

Sub Main()
If OpenData = True Then
frmMain.Show
Else
MsgBox "Cannot Open Connection!", vbCritical, "Error!"
End
End If
End Sub

Function OpenData() As Boolean
On Error GoTo ErrorCode
Set PPISconn = New ADODB.Connection
Set PPISconn = dePPIS.deConnPPIS
PPISconn.Open
OpenData = True
Exit Function

ErrorCode:
OpenData = False
End Function

Function Null2string(XXX As String) As String
If IsNull(XXX) = True Then
Null2string = ""
Else
Null2string = XXX
End If
End Function

Function String2Null(XXX As String) As String
If IsNull(XXX) = True Or Trim(XXX) = "" Then
String2Null = "NULL"
Else
String2Null = "'" & XXX & "'"
End If
End Function

Public Sub CenterMe(TheseForm As Object)
TheseForm.Top = (Screen.Height - TheseForm.Height - 800) \ 2
TheseForm.Left = (Screen.Width - TheseForm.Width) \ 2
End Sub