Hi sime tyres!
I hope this will be of help. Below is a sample vb6 class called clsDrivers. It is part of the DB_Server.vbp (when compiled becomes DB_Server.dll).
I write vb6 programs using the 3-tier approach. The following functions are called by the procedures in the DB_Client.vbp (when compiled becomes the DB_Client.exe).
Option Explicit
Dim strSQL As String ' declare a string
Dim conDB As ADODB.Connection ' declare a database connection
Private Sub Class_Initialize()
Set conDB = New ADODB.Connection
'conDB.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
' "Data Source =C:\LUECO\MotorPool.mdb"
conDB.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source =D:\LUECO\MotorPool.mdb"
End Sub
Private Sub Class_Terminate()
Set conDB = Nothing
End Sub
Public Function Add_Driver(strID As String, strLast As String, strFirst As _
String, strLicense As String, dtExpiry As Date) As Boolean
Dim rsDrivers As New ADODB.Recordset
On Error GoTo ErrHandler
conDB.Open
conDB.CursorLocation = adUseServer
strSQL = "SELECT * FROM drivers WHERE 1=2"
rsDrivers.LockType = adLockOptimistic
rsDrivers.CursorType = adOpenKeyset
rsDrivers.Open strSQL, conDB
conDB.BeginTrans
With rsDrivers
.AddNew
.Fields("Driver_ID") = strID
.Fields("Last_Name") = strLast
.Fields("First_Name") = strFirst
.Fields("License_No") = strLicense
.Fields("Expiry_Date") = dtExpiry
.Update
End With
conDB.CommitTrans
Add_Driver = True
conDB.Close
Exit Function
ErrHandler:
Debug.Print "Error No. : " & Err.Number
Debug.Print "Description: " & Err.Description
conDB.RollbackTrans
conDB.Close
Add_Driver = False
End Function
Public Function Update_Driver(strID As String, strLast As String, strFirst As _
String, strLicense As String, dtExpiry As Date) As Boolean
Dim rsDrivers As New ADODB.Recordset
On Error GoTo ErrHandler
conDB.Open
conDB.CursorLocation = adUseServer
strSQL = "SELECT * FROM drivers WHERE Driver_ID ='" & strID & "'"
rsDrivers.LockType = adLockOptimistic
rsDrivers.CursorType = adOpenKeyset
rsDrivers.Open strSQL, conDB
conDB.BeginTrans
With rsDrivers
.Fields("Last_Name") = strLast
.Fields("First_Name") = strFirst
.Fields("License_No") = strLicense
.Fields("Expiry_Date") = dtExpiry
.Update
End With
conDB.CommitTrans
Update_Driver = True
conDB.Close
Exit Function
ErrHandler:
Debug.Print "Error No. : " & Err.Number
Debug.Print "Description: " & Err.Description
conDB.RollbackTrans
conDB.Close
Update_Driver = False
End Function
Public Function Delete_Driver(strID As String) As Boolean
On Error GoTo ErrHandler
conDB.Open
conDB.CursorLocation = adUseServer
strSQL = "DELETE FROM drivers WHERE Driver_ID ='" & strID & "'"
conDB.BeginTrans
conDB.Execute strSQL
conDB.CommitTrans
Delete_Driver = True
conDB.Close
Exit Function
ErrHandler:
Debug.Print "Error No. : " & Err.Number
Debug.Print "Description: " & Err.Description
conDB.RollbackTrans
conDB.Close
Delete_Driver = False
End Function
Public Function Select_Driver(Optional strID As String) As ADODB.Recordset
Dim rsDrivers As New ADODB.Recordset
On Error GoTo ErrHandler
conDB.Open
conDB.CursorLocation = adUseServer
strSQL = "SELECT * FROM drivers"
If Trim("" & strID) <> "" Then
strSQL = strSQL & " WHERE Driver_ID ='" & strID & "'"
End If
strSQL = strSQL & " ORDER BY Last_Name, First_Name"
rsDrivers.LockType = adLockOptimistic
rsDrivers.CursorType = adOpenKeyset
rsDrivers.Open strSQL, conDB
Set Select_Driver = rsDrivers
Exit Function
ErrHandler:
Debug.Print "Error No. : " & Err.Number
Debug.Print "Description: " & Err.Description
conDB.Close
Set Select_Driver = Nothing
End Function
Public Function Select_Driver_ByName(strLast As String, strFirst As String) As _
ADODB.Recordset
Dim rsDrivers As New ADODB.Recordset
On Error GoTo ErrHandler
conDB.Open
conDB.CursorLocation = adUseServer
strSQL = "SELECT * FROM drivers"
strSQL = strSQL & " WHERE Last_Name ='" & strLast & "'"
strSQL = strSQL & " AND First_Name ='" & strFirst & "'"
strSQL = strSQL & " ORDER BY Last_Name, First_Name"
rsDrivers.LockType = adLockOptimistic
rsDrivers.CursorType = adOpenKeyset
rsDrivers.Open strSQL, conDB
Set Select_Driver_ByName = rsDrivers
Exit Function
ErrHandler:
Debug.Print "Error No. : " & Err.Number
Debug.Print "Description: " & Err.Description
conDB.Close
Set Select_Driver_ByName = Nothing
End Function
'------------------------------------------
this is the frmDrivers of the DB_Client.vbp
it uses the clsDrivers of the DB_Server.vbp
to perform the tasks.
-------------------------------------------
Option Explicit
Dim iCurrentState As Integer
Private Sub cmdAdd_Click()
iCurrentState = NOW_ADDING
clearFields
lockFields (False)
txtDriverID.SetFocus
cmdAdd.Enabled = False
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = False
cmdOK.Enabled = True
cmdCancel.Enabled = True
End Sub
Private Sub cmdCancel_Click()
iCurrentState = NOW_IDLE
clearFields
lockFields (True)
cmdAdd.Enabled = True
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = True
cmdOK.Enabled = False
cmdCancel.Enabled = False
End Sub
Private Sub cmdDelete_Click()
Dim strWarning As String
strWarning = "Deleting this record will remove it permanently" & vbCrLf & _
"from the database. Are you sure you want to proceed?"
If MsgBox(strWarning, vbYesNo, progname) = vbYes Then
deleteDriver
End If
End Sub
Private Sub cmdEdit_Click()
iCurrentState = NOW_EDITING
lockFields (False)
txtDriverID.Locked = True
txtDriverID.BackColor = vbCyan
txtLastName.SetFocus
cmdAdd.Enabled = False
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = False
cmdOK.Enabled = True
cmdCancel.Enabled = True
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
If validEntries() Then
If iCurrentState = NOW_ADDING Then
If noDupe() Then
saveNewDriver
Else
MsgBox "Duplicate driver record id found.", vbInformation, progname
txtDriverID.SetFocus
Exit Sub
End If
ElseIf iCurrentState = NOW_EDITING Then
updateDriver
End If
End If
End Sub
Private Sub Form_Activate()
iCurrentState = NOW_IDLE
clearFields
lockFields (True)
populateDrivers
cmdAdd.Enabled = True
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = True
cmdOK.Enabled = False
cmdCancel.Enabled = False
End Sub
Private Sub Form_Load()
iCurrentState = NOW_IDLE
End Sub
Private Sub lvDrivers_Click()
If lvDrivers.ListItems.Count >= 1 Then
getDriver
Else
MsgBox "There are no driver records listed yet.", vbInformation, progname
End If
End Sub
Private Sub txtDriverID_GotFocus()
If iCurrentState = NOW_EDITING Then
MsgBox "This is locked when program is in edit mode." & vbCrLf & _
"Change/modification not allowed.", vbInformation, progname
Exit Sub
End If
hiLite
End Sub
Private Sub txtDriverID_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub
Private Sub txtFirstName_GotFocus()
hiLite
End Sub
Private Sub txtFirstName_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub
Private Sub txtLastName_GotFocus()
hiLite
End Sub
Private Sub txtLastName_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub
Private Function noDupe() As Boolean
Dim objMpool As New MPool_Server.clsDrivers
Dim rsRec As New ADODB.Recordset
Set rsRec = objMpool.Select_Driver(Trim(txtDriverID.Text))
If rsRec.EOF And rsRec.BOF Then
Set rsRec = Nothing
Set objMpool = Nothing
noDupe = True
Else
Set rsRec = Nothing
Set objMpool = Nothing
noDupe = False
End If
End Function
Private Function validEntries() As Boolean
validEntries = True
If iCurrentState = NOW_ADDING Then
If txtDriverID.Text = "" Then
validEntries = False
txtDriverID.SetFocus
MsgBox "Driver id must not be blank or empty.", vbInformation, progname
Exit Function
End If
End If
If txtLastName.Text = "" Then
validEntries = False
txtLastName.SetFocus
MsgBox "Driver last name must not be blank or empty.", vbInformation, progname
Exit Function
End If
If txtFirstName.Text = "" Then
validEntries = False
txtFirstName.SetFocus
MsgBox "Driver first name must not be blank or empty.", vbInformation, progname
Exit Function
End If
End Function
Private Sub saveNewDriver()
Dim objMpool As New MPool_Server.clsDrivers
Dim bSaved As Boolean
iCurrentState = NOW_SAVING
bSaved = objMpool.Add_Driver(Trim(txtDriverID.Text), Trim(txtLastName.Text), _
Trim(txtFirstName.Text), Trim(txtLicNum.Text), CDate(txtLicExpiry.Text))
If bSaved = True Then
MsgBox "Driver record added to database.", vbInformation, progname
Else
MsgBox "Driver record was not added to database.", vbInformation, progname
End If
Set objMpool = Nothing
iCurrentState = NOW_IDLE
clearFields
lockFields (True)
populateDrivers
cmdAdd.Enabled = True
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = True
cmdOK.Enabled = False
cmdCancel.Enabled = False
End Sub
Private Sub updateDriver()
Dim objMpool As New MPool_Server.clsDrivers
Dim bSaved As Boolean
iCurrentState = NOW_SAVING
bSaved = objMpool.Update_Driver(Trim(txtDriverID.Text), Trim(txtLastName.Text), _
Trim(txtFirstName.Text), Trim(txtLicNum.Text), CDate(txtLicExpiry.Text))
If bSaved = True Then
MsgBox "Driver record successfullly updated.", vbInformation, progname
Else
MsgBox "Driver record update failed.", vbInformation, progname
End If
Set objMpool = Nothing
iCurrentState = NOW_IDLE
clearFields
lockFields (True)
populateDrivers
cmdAdd.Enabled = True
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = True
cmdOK.Enabled = False
cmdCancel.Enabled = False
End Sub
Private Sub deleteDriver()
Dim objMpool As New MPool_Server.clsDrivers
Dim bDeleted As Boolean
iCurrentState = NOW_DELETING
bDeleted = objMpool.Delete_Driver(Trim(txtDriverID.Text))
If bDeleted = True Then
MsgBox "Driver record successfullly removed.", vbInformation, progname
Else
MsgBox "Driver record delete failed.", vbInformation, progname
End If
Set objMpool = Nothing
iCurrentState = NOW_IDLE
clearFields
lockFields (True)
populateDrivers
cmdAdd.Enabled = True
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = True
cmdOK.Enabled = False
cmdCancel.Enabled = False
End Sub
Private Sub populateDrivers()
Dim objMpool As New MPool_Server.clsDrivers
Dim rsRec As New ADODB.Recordset
Dim itmRec As ListItem
lvDrivers.ListItems.Clear
Set rsRec = objMpool.Select_Driver
If rsRec.EOF And rsRec.BOF Then
Set rsRec = Nothing
Set objMpool = Nothing
MsgBox "No driver records found.", vbInformation, progname
Exit Sub
End If
rsRec.MoveFirst
While Not rsRec.EOF
Set itmRec = lvDrivers.ListItems.Add _
(, , rsRec("Driver_ID"))
itmRec.SubItems(1) = rsRec("Last_Name")
itmRec.SubItems(2) = rsRec("First_Name")
rsRec.MoveNext
Wend
Set rsRec = Nothing
Set objMpool = Nothing
End Sub
Private Sub getDriver()
Dim objMpool As New MPool_Server.clsDrivers
Dim rsRec As New ADODB.Recordset
Set rsRec = objMpool.Select_Driver(lvDrivers.SelectedItem.Text )
If rsRec.EOF And rsRec.BOF Then
Set rsRec = Nothing
Set objMpool = Nothing
MsgBox "Selected driver record not found.", vbInformation, progname
Exit Sub
End If
txtDriverID.Text = rsRec("Driver_ID")
txtLastName.Text = rsRec("Last_Name")
txtFirstName.Text = rsRec("First_Name")
txtLicNum.Text = rsRec("License_No")
txtLicExpiry.Text = Format(rsRec("Expiry_Date"), "Short Date")
Set rsRec = Nothing
Set objMpool = Nothing
showPic
cmdAdd.Enabled = False
cmdEdit.Enabled = True
cmdDelete.Enabled = True
cmdExit.Enabled = True
cmdOK.Enabled = False
cmdCancel.Enabled = False
End Sub
Private Sub txtLicExpiry_GotFocus()
If IsDate(txtLicExpiry.Text) Then
txtLicExpiry.Text = Format(CDate(txtLicExpiry.Text), "Short Date")
End If
hiLite
End Sub
Private Sub txtLicExpiry_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub
Private Sub txtLicExpiry_LostFocus()
If IsDate(txtLicExpiry.Text) Then
txtLicExpiry.Text = Format(CDate(txtLicExpiry.Text), "Short Date")
End If
End Sub
Private Sub txtLicNum_GotFocus()
hiLite
End Sub
Private Sub txtLicNum_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub
Private Sub showPic()
Dim objFS As New FileSystemObject
Dim strFile As String
Dim strPath As String
strFile = App.Path & "\DriverPics\" & Trim(txtDriverID.Text) & ".JPG"
If objFS.FileExists(strFile) Then
imgDriverPic.Picture = LoadPicture(strFile)
lblDriverPic.Caption = "Driver's Picture"
Else
imgDriverPic.Picture = LoadPicture(App.Path & "\DriverPics\NoPic.JPG")
lblDriverPic.Caption = "No Picture"
End If
End Sub
Go through the code, you will see how the task is done.
If yuu are not familiar with the 3-tier approach, let me know. I'll try to help.
JFe'
|
