r
sion from tblFreemanLookup Order by SeqId", db, adOpenStatic,
adLockOptimistic
Do Until adoPrimaryRS.EOF
cboList.AddItem adoPrimaryRS!LookupField
cboList.ItemData(cboList.NewIndex) = adoPrimaryRS!SeqId
adoPrimaryRS.MoveNext
Loop
adoPrimaryRS.MoveFirst
cboList = txtData(0)
mbDataChanged = False
frmGstMain_Exit:
Exit Sub
frmGstMain_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo Form_KeyDown_Err
If mbEditFlag Or mbAddNewFlag Then Exit Sub
Select Case KeyCode
Case vbKeyEscape
cmdClose_Click
Case vbKeyEnd
cmdLast_Click
Case vbKeyHome
cmdFirst_Click
Case vbKeyUp, vbKeyPageUp
If Shift = vbCtrlMask Then
cmdFirst_Click
Else
cmdPrevious_Click
End If
Case vbKeyDown, vbKeyPageDown
If Shift = vbCtrlMask Then
cmdLast_Click
Else
cmdNext_Click
End If
End Select
Form_KeyDown_Exit:
Exit Sub
Form_KeyDown_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub Form_Terminate()
On Error GoTo Form_Terminate_Err
'Make sure that db connection is closed no matter
'what; to release resources
If db.State <> 0 Then
db.Close
End If
'Make sure that ADO RecordSet variable is released;
'to free resources
Set adoPrimaryRS = Nothing
Form_Terminate_Exit:
Exit Sub
Form_Terminate_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo Form_Unload_Err
Screen.MousePointer = vbDefault
Form_Unload_Exit:
Exit Sub
Form_Unload_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As
ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As
ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
On Error GoTo adoPrimaryRS_MoveComplete_Err
lblStatus.Caption = CStr(adoPrimaryRS.AbsolutePosition)
If Not adoPrimaryRS.EOF Then
PopData
End If
bEditMode = True
bChanged = False
adoPrimaryRS_MoveComplete_Exit:
Exit Sub
adoPrimaryRS_MoveComplete_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As
ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As
ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
On Error GoTo adoPrimaryRS_WillChangeRecord_Err
Dim bCancel As Boolean
Select Case adReason
Case adRsnAddNew
Case adRsnClose
Case adRsnDelete
Case adRsnFirstChange
Case adRsnMove
Case adRsnRequery
Case adRsnResynch
Case adRsnUndoAddNew
Case adRsnUndoDelete
Case adRsnUndoUpdate
Case adRsnUpdate
End Select
If bCancel Then adStatus = adStatusCancel
adoPrimaryRS_WillChangeRecord_Exit:
Exit Sub
adoPrimaryRS_WillChangeRecord_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdAdd_Click()
On Error GoTo AddErr
' With adoPrimaryRS
' If Not (.BOF And .EOF) Then
' mvBookMark = .Bookmark
' End If
' .AddNew
' lblRecord.Caption = "Add record"
' mbAddNewFlag = True
' SetButtons False
' End With
Dim txtAdd As TextBox
For Each txtAdd In txtData
txtAdd.Text = ""
Next
cmdSave.Visible = True
Add_Exit:
Exit Sub
AddErr:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdDelete_Click()
On Error GoTo DeleteErr
With adoPrimaryRS
.Delete
.MoveNext
If .EOF Then .MoveLast
End With
Delete_Exit:
Exit Sub
DeleteErr:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdRefresh_Click()
On Error GoTo RefreshErr
adoPrimaryRS.Requery
If Not cboList = txtData(0) Then
adoPrimaryRS.Find "SeqId = " &
cboList.ItemData(cboList.ListIndex)
End If
RefreshErr_Exit:
Exit Sub
RefreshErr:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdEdit_Click()
On Error GoTo EditErr
lblRecord.Caption = "Edit record"
mbEditFlag = True
SetButtons False
EditErr_Exit:
Exit Sub
EditErr:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdCancel_Click()
On Error Resume Next
SetButtons True
mbEditFlag = False
mbAddNewFlag = False
adoPrimaryRS.CancelUpdate
If mvBookMark > 0 Then
adoPrimaryRS.Bookmark = mvBookMark
Else
adoPrimaryRS.MoveFirst
End If
mbDataChanged = False
End Sub
Private Sub cmdUpdate_Click()
On Error GoTo UpdateErr
adoPrimaryRS.UpdateBatch adAffectAll
If mbAddNewFlag Then
adoPrimaryRS.MoveLast 'move to the new record
End If
mbEditFlag = False
mbAddNewFlag = False
SetButtons True
mbDataChanged = False
UpdateErr_Exit:
Exit Sub
UpdateErr:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdClose_Click()
On Error GoTo cmdClose_Err
'Make sure that db connection is closed no matter
'what; to release resources
If db.State <> 0 Then
db.Close
End If
'Make sure that ADO RecordSet variable is released;
'to free resources
Set adoPrimaryRS = Nothing
Unload Me
cmdClose_Exit:
Exit Sub
cmdClose_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdFirst_Click()
On Error GoTo GoFirstError
adoPrimaryRS.MoveFirst
mbDataChanged = False
cboList = txtData(0)
GoFirstError_Exit:
Exit Sub
GoFirstError:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdLast_Click()
On Error GoTo GoLastError
adoPrimaryRS.MoveLast
mbDataChanged = False
cboList = txtData(0)
GoLastError_Exit:
Exit Sub
GoLastError:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdNext_Click()
On Error GoTo GoNextError
adoPrimaryRS.MoveNext
' If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
' If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
' Beep
'moved off the end so go back
' adoPrimaryRS.MoveLast
cboList = txtData(0)
' adoPrimaryRS.Requery
' End If
'show the current record
mbDataChanged = False
GoNextError_Exit:
Exit Sub
GoNextError:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub cmdPrevious_Click()
On Error GoTo GoPrevError
' If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
' If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
' Beep
adoPrimaryRS.MoveFirst
cboList = txtData(0)
' End If
mbDataChanged = False
GoPrevError_Exit:
Exit Sub
GoPrevError:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub SetButtons(bVal As Boolean)
On Error GoTo SetButtons_Err
cmdAdd.Visible = bVal
cmdEdit.Visible = bVal
cmdUpdate.Visible = Not bVal
cmdCancel.Visible = Not bVal
cmdDelete.Visible = bVal
cmdClose.Visible = bVal
cmdRefresh.Visible = bVal
cmdNext.Enabled = bVal
cmdFirst.Enabled = bVal
cmdLast.Enabled = bVal
cmdPrevious.Enabled = bVal
SetButtons_Err_Exit:
Exit Sub
SetButtons_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub PopData()
'On Error Resume Next
On Error GoTo PopData_Err
Dim vItem As TextBox
For Each vItem In txtData
vItem.Text = adoPrimaryRS(vItem.Tag) & " "
Next
PopData_Err_Exit:
Exit Sub
PopData_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub DoInsert()
On Error GoTo DoInsert_Err
Dim vItem As TextBox
Dim ssql As String
Dim sFlds As String
Dim sVals As String
ssql = "INSERT INTO tblFREEMANLOOKUP ("
For Each vItem In txtData
If Len(Trim(vItem.Text)) Then
sFlds = sFlds & vItem.Tag & ", "
Select Case vItem.Index
Case 0, 2, 6, 7, 8, 10 'Text
sVals = "'" & sVals & vItem.Text & "', "
Case 3, 4, 5, 9 'Numbers
sVals = sVals & vItem.Text & ", "
Case 1 'Dates
sVals = "#" & sVals & vItem.Text & "#, "
End Select
End If
Next
sVals = Left$(sVals, Len(sVals) - 2)
sFlds = Left$(sFlds, Len(sFlds) - 2)
ssql = ssql & sFlds & ") values (" & sVals & ")"
' MsgBox ssql
Dim lcount As Long
adoPrimaryRS.MoveLast
If Not adoPrimaryRS.State Then
adoPrimaryRS.Close
End If
adoPrimaryRS.Open ssql
adoPrimaryRS.Open "Select Max(SeqId)as x From tblFreemanLookup"
lcount = adoPrimaryRS!x + 1
If Not adoPrimaryRS.State Then
adoPrimaryRS.Close
End If
adoPrimaryRS.Open "UPDATE tblFreemanLookup SET
tblFreemanLookup.LookupField = ('(' & [tblFreemanLookup]![SeqId] & ')' & ' '
& [tblFreemanLookup]![UPC] & '-' & [tblFreemanLookup]![Version]) where
seqid = " & lcount
DoInsert_Err_Exit:
Exit Sub
DoInsert_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub DoUpdate()
On Error GoTo DoUpdate_Err
Dim vItem As TextBox
Dim ssql As String
ssql = "UPDATE tblFreemanLookup Set"
For Each vItem In txtData
Select Case vItem.Index
Case 0, 2, 6, 7, 8, 10 'Text
ssql = ssql & vItem.Tag & " = '" & IIf(Len(Trim(vItem.Text)) =
0, "", vItem.Text) & "', "
Case 3, 4, 5, 9 'Numbers
ssql = ssql & vItem.Tag & " = " & IIf(Len(Trim(vItem.Text)) = 0,
"NULL", vItem.Text) & ", "
Case 1 'Dates
ssql = ssql & vItem.Tag & " = " & IIf(Len(Trim(vItem.Text)) = 0,
"NULL", "#" & vItem.Text & "#, ")
End Select
Next
ssql = Left$(ssql, Len(ssql) - 1)
ssql = ssql & " where seqid = " & txtData(9)
adoPrimaryRS.Open ssql
' MsgBox ssql
DoUpdate_Err_Exit:
Exit Sub
DoUpdate_Err:
MsgBox Err.Number & "," & " " & Err.Description
End Sub
Private Sub txtData_Change(Index As Integer)
On Error GoTo txtData_Change_Err
If Not bEditMode Then Exit Sub
bChanged = True
txtData_Change_Err_Exit:
Exit Sub
txtData_Change_Err:
MsgBox Err.Number & "," & " " & Err.Number
End Sub