I have a code in my form, once you type in an employees id it searches a table and auto fills the corresponding data. If the number is incomplete or is not in the table an error window pops up
And below is the code:
The Me.txtEmpName = rec("EMP_NA") is highlighted. I would like in the instance of an incomplete ID or if the ID does not exist, a msg box appears saying that employee id is not valid, please try again. or something along those lines, then it just goes back to the form instead of getting the error message above. Any thoughts?
Private Sub txtEmpID_AfterUpdate()
Dim db As DAO.Database
Dim rec As DAO.Recordset
Set db = CurrentDb
strSQL = "Select * From tblEmpData Where TMSID = '" & Me.txtEmpID & "'"
Set rec = db.OpenRecordset(strSQL)
Me.txtEmpName = rec("EMP_NA")
Me.cboGender = rec("EMP_SEX_TYP_CD")
Me.cboEEOC = rec("EMP_EOC_GRP_TYP_CD")
Me.txtDivision = rec("DIV_NR")
Me.txtCenter = rec("CTR_NR")
Me.cboRR = rec("REG_NR")
Me.cboDD = rec("DIS_NR")
Me.txtJobD = rec("JOB_CLS_CD_DSC_TE")
Me.cboJobGroupCode = rec("JOB_GRP_CD")
Me.cboFunction = rec("JOB_FUNCTION")
Me.cboMtgReadyLvl = rec("Meeting_Readiness_Rating")
Me.cboMgrReadyLvl = rec("Manager_Readiness_Rating")
Me.cboJobGroup = rec("JOB_GROUP")
Set rec = Nothing
Set db = Nothing
End Sub
After you open the recordset, check whether it is empty. If empty, present your message. If not empty, load the recordset values into your data controls.
Set rec = db.OpenRecordset(strSQL)
If (rec.BOF And rec.EOF) Then
' when both BOF and EOF are True, the recordset is empty
MsgBox "employee id is not valid, please try again"
Else
Me.txtEmpName = rec("EMP_NA")
' and so forth
End If
The following code will fix the issue you are having. 1. You are not finding a record, thus the error you received. 2. If you want to handle other errors, change the code in the Error_Trap to test for the error number.
Private Sub txtEmpID_AfterUpdate()
Dim db As DAO.Database
Dim rec As DAO.Recordset
On Error GoTo Error_Trap
Set db = CurrentDb
strSQL = "Select * From tblEmpData Where TMSID = '" & Me.txtEmpID & "'"
Set rec = db.OpenRecordset(strSQL)
If rec.EOF Then
MsgBox "The Employee ID you entered was not found. Please try again", vbOKOnly, "Wrong ID"
GoTo Close_It
End If
Me.txtEmpName = rec("EMP_NA")
Me.cboGender = rec("EMP_SEX_TYP_CD")
Me.cboEEOC = rec("EMP_EOC_GRP_TYP_CD")
Me.txtDivision = rec("DIV_NR")
Me.txtCenter = rec("CTR_NR")
Me.cboRR = rec("REG_NR")
Me.cboDD = rec("DIS_NR")
Me.txtJobD = rec("JOB_CLS_CD_DSC_TE")
Me.cboJobGroupCode = rec("JOB_GRP_CD")
Me.cboFunction = rec("JOB_FUNCTION")
Me.cboMtgReadyLvl = rec("Meeting_Readiness_Rating")
Me.cboMgrReadyLvl = rec("Manager_Readiness_Rating")
Me.cboJobGroup = rec("JOB_GROUP")
Close_It:
Set rec = Nothing
Set db = Nothing
Exit Sub
Error_Trap:
If Err.Number = 99999999 Then ' Change this line to test for other conditions
MsgBox "...... ", vbOKOnly, "....."
Resume Close_It
End If
End Sub
Related
I've been running into issues with this code. It works fine if I restart the computer and run it, but once the code has been run once it starts to cause errors. I will either get either the "save error" or the "admin error" because the file (either the original or the other) is un-accessible. I can sometimes close down background excel programs from the task-manager to fix it (but not always)
The code's purpose is to download an excel sheet off the internet and add the new rows (and update the old rows) to an ms-access Database.
Whats peculiar is I haven't been able to see any trend with the logical errors.
Const localSaveLocation = ########
Const NetworkDSRTLocation = ########
Private Sub download_btn_Click()
Dim xlsApp As Excel.Application
Dim xlsBook As Excel.Workbook
Dim xlsSheet As Excel.Worksheet
On Error GoTo adminError
Set xlsBook = Workbooks.Open(NetworkDSRTLocation)
Set xlsApp = xlsBook.Parent
On Error GoTo 0
' go to the ERS tab of the workbook, delete the first 3 rows
Worksheets("ERS").Select
Set xlsSheet = xlsBook.Worksheets("ERS")
For row_ctr = 1 To 3
xlsSheet.Rows(1).EntireRow.Delete
Next row_ctr
'set up 'ERS' named range for all cells in this worksheet
xlsSheet.UsedRange.Select
col_count = Cells(1, Columns.Count).end(xlToLeft).Column
row_count = (xlsSheet.Cells(Rows.Count, 1).end(xlUp).Row) + 1
ActiveWorkbook.Names.Add name:="ERS", RefersToR1C1:="=ERS!R1C1:R" & row_count & "C" & col_count
On Error GoTo saveError
Kill localSaveLocation
xlsBook.SaveAs FileName:=localSaveLocation
xlsApp.Quit
On Error GoTo 0
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "DSRT_TEMP", localSaveLocation, True, "ERS"
numOfChangesDSRT = DCount("ID", "changed_records")
DoCmd.RunSQL "update ers_local inner join changed_records on changed_records.id = ers_local.id Set last_updated = Date();"
DoCmd.RunSQL "update ers_local inner join dsrt_temp on dsrt_temp.id = ers_local.id Set source = 'DSRT';"
DoCmd.RunSQL "DELETE FROM [dsrt_ers] WHERE dsrt_ers.id in (select id from ers_local where source = 'DSRT');"
DoCmd.RunSQL "INSERT INTO DSRT_ERS SELECT * FROM DSRT_TEMP"
DoCmd.RunSQL "DROP TABLE DSRT_TEMP;"
xlsApp.Quit
DoCmd.Requery
DoCmd.Hourglass False
Exit Sub
adminError:
DoCmd.Hourglass False
Exit Sub
saveError:
DoCmd.Hourglass False
On Error Resume Next
xlsApp.Quit
Exit Sub
End Sub
Be very careful opening and closing the Excel objects correctly:
Const localSaveLocation = ########
Const NetworkDSRTLocation = ########
Private Sub download_btn_Click()
Dim xlsApp As Excel.Application
Dim xlsBook As Excel.Workbook
Dim xlsSheet As Excel.Worksheet
Set xlsApp = New Excel.Application
Set xlsBook = xlsApp.Workbooks.Open(NetworkDSRTLocation)
' Go to the ERS tab of the workbook, delete the first 3 rows.
Set xlsSheet = xlsBook.Worksheets("ERS")
For row_ctr = 1 To 3
xlsSheet.Rows(1).EntireRow.Delete
Next row_ctr
' Set up 'ERS' named range for all cells in this worksheet.
xlsSheet.UsedRange.Select
col_count = xlsSheet.Cells(1, Columns.Count).end(xlToLeft).Column
row_count = (xlsSheet.Cells(Rows.Count, 1).end(xlUp).Row) + 1
xlsBook.Names.Add name:="ERS", RefersToR1C1:="=ERS!R1C1:R" & row_count & "C" & col_count
If Dir(localSaveLocation, vbNormal) <> "" Then
Kill localSaveLocation
End If
xlsBook.SaveAs FileName:=localSaveLocation
Set xlsSheet = Nothing
xlsBook.Close
Set xlsBook = Nothing
xlsApp.Quit
Set xlsApp = Nothing
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "DSRT_TEMP", localSaveLocation, True, "ERS"
numOfChangesDSRT = DCount("ID", "changed_records")
DoCmd.RunSQL "update ers_local inner join changed_records on changed_records.id = ers_local.id Set last_updated = Date();"
DoCmd.RunSQL "update ers_local inner join dsrt_temp on dsrt_temp.id = ers_local.id Set source = 'DSRT';"
DoCmd.RunSQL "DELETE FROM [dsrt_ers] WHERE dsrt_ers.id in (select id from ers_local where source = 'DSRT');"
DoCmd.RunSQL "INSERT INTO DSRT_ERS SELECT * FROM DSRT_TEMP"
DoCmd.RunSQL "DROP TABLE DSRT_TEMP;"
DoCmd.Requery
DoCmd.Hourglass False
End Sub
How can i make an error trap that would ignore any null value extracted from ms access database)?
i want my program to just ignore any null value returned and just continue as i don't have a problem for a blank data to be showed on my form.
in this code, the error highlights
.SubItems(6) = rs3!Regularization_Date
because Regularization_Date is blank on my databse. i want my program to just ignore this one and continue filling out my listview with all the data there is to show.
Private Function SearchData()
Result.Show
Result.ListView1.ListItems.Clear
Sql = "SELECT * FROM All_Employees WHERE ID LIKE '" & (Text1.Text) & "'"
Set rs3 = New ADODB.Recordset
rs3.Open Sql, con3, adOpenDynamic, adLockOptimistic
If Not rs3.EOF Then
Do Until rs3.EOF
Set lst1 = Result.ListView1.ListItems.Add(, , rs3!ID)
With lst1
.SubItems(1) = rs3!Lastname
.SubItems(2) = rs3!FirstName
.SubItems(3) = rs3!Position
.SubItems(4) = rs3!Date_hired
.SubItems(5) = rs3!Employment_Status
*.SubItems(6) = rs3!Regularization_Date*
.SubItems(7) = rs3!Office_email
.SubItems(8) = rs3!Shift_Start
.SubItems(9) = rs3!Shift_End
End With
rs3.MoveNext
Loop
End If
Set rs3 = Nothing
End Function
i just want an errortrap that would ignore all null values.
You could use the IsNull function to check the value in the field.
It would look something like this:
.SubItems(1) = rs3!Lastname
.SubItems(2) = rs3!FirstName
.SubItems(3) = rs3!Position
.SubItems(4) = rs3!Date_hired
.SubItems(5) = rs3!Employment_Status
if not IsNull(rs3!Regularization_Date) then
.SubItems(6) = rs3!Regularization_Date
end if
.SubItems(7) = rs3!Office_email
.SubItems(8) = rs3!Shift_Start
.SubItems(9) = rs3!Shift_End
You can find more information here IsNull Docs on Microsoft
If you really wanted it in an error handler you could do it like this:
Private Function SearchData()
on error goto ErrHandler:
Result.Show
Result.ListView1.ListItems.Clear
Sql = "SELECT * FROM All_Employees WHERE ID LIKE '" & (Text1.Text) & "'"
Set rs3 = New ADODB.Recordset
rs3.Open Sql, con3, adOpenDynamic, adLockOptimistic
If Not rs3.EOF Then
Do Until rs3.EOF
Set lst1 = Result.ListView1.ListItems.Add(, , rs3!ID)
With lst1
.SubItems(1) = rs3!Lastname
.SubItems(2) = rs3!FirstName
.SubItems(3) = rs3!Position
.SubItems(4) = rs3!Date_hired
.SubItems(5) = rs3!Employment_Status
.SubItems(6) = rs3!Regularization_Date
.SubItems(7) = rs3!Office_email
.SubItems(8) = rs3!Shift_Start
.SubItems(9) = rs3!Shift_End
End With
rs3.MoveNext
Loop
End If
Cleanup:
Set rs3 = Nothing
exit function
ErrHandler:
dim intErrNo as integer
dim strErrMsg as string
intErrNo = Err.Number
strErrMsg = Err.Description
if intErrNo = 94 then
'Null Value continue with the next line of the code
resume next
else
MsgBox "Error Number: " & intErrNo & vbCrLF & "Description : " & strErrMsg
GoTo CleanUp
end if
End Function
You modify the error handling to display what you want, or just log the error.
Just as a suggestion, you could change the function to a sub because you aren't returning anything.
If you just want to ignore the error, you could use On Error Resume Next
Private Function SearchData()
Result.Show
Result.ListView1.ListItems.Clear
Sql = "SELECT * FROM All_Employees WHERE ID LIKE '" & (Text1.Text) & "'"
**On Error Resume Next**
Set rs3 = New ADODB.Recordset
rs3.Open Sql, con3, adOpenDynamic, adLockOptimistic
If Not rs3.EOF Then
Do Until rs3.EOF
Set lst1 = Result.ListView1.ListItems.Add(, , rs3!ID)
With lst1
.SubItems(1) = rs3!Lastname
.SubItems(2) = rs3!FirstName
.SubItems(3) = rs3!Position
.SubItems(4) = rs3!Date_hired
.SubItems(5) = rs3!Employment_Status
*.SubItems(6) = rs3!Regularization_Date*
.SubItems(7) = rs3!Office_email
.SubItems(8) = rs3!Shift_Start
.SubItems(9) = rs3!Shift_End
End With
rs3.MoveNext
Loop
End If
Set rs3 = Nothing
End Function
I am trying to delete duplicate records in MS ACCESS.
I have created a query that is sorted on field name.
I have VBA code that runs through the query, and then when finds a match it deletes the record - however it is not picking up the match.
My code looks as follows:
Dim db As DAO.Database
Dim recIn As DAO.Recordset
Dim strFieldName1 As Variant
Dim strFieldDescr2 As Variant
Dim strDomainCat3 As Variant
Dim strBusinessTerm4 As Variant
Dim strtableName5 As Variant
Dim lngRecordsDeleted As Variant
lngRecordsDeleted = 0
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryMyRecords")
If recIn.EOF Then
MsgBox ("No Input Records")
recIn.Close
Set recIn = Nothing
Set db = Nothing
Exit Sub
End If
Do
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Else
strFieldName1 = recIn!FieldName
strFieldDescr2 = recIn!FieldDescr
strDomainCat3 = recIn!DomainCatID
strBusinessTerm4 = recIn!BusinessTermID
strtableName5 = recIn!TableID
End If
recIn.MoveNext
Loop Until recIn.EOF
recIn.Close
Set recIn = Nothing
Set db = Nothing
MsgBox ("You Deleted " & lngRecordsDeleted & " Records")
End Sub
My StrFieldname1, through to to StrTablename5 does populate (after the else statement)
However when I do the compare a second time
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Even though the values are the same, it moves to the else statement, and never does the record delete.
Now I suspect that this could be because I declared my variables as VARIANT type, but if I use any other type, the code falls over every time it reaches a NULL value in the query, and there are cases where any of the fields from the query can and will be null.
Any suggestions would be greatly appreciated
To expand on what Justin said, use the Nz function in your main If statement, like so:
If Nz(recIn!FieldName, "") = strFieldName1 And _
...
Else
strFieldName1 = Nz(recIn!FieldName, "")
...
I have two linked Tables 'tblPatients' and 'tblDSA' and two continues forms 'frmPatients' and 'frmDSA'. When I create a new patient via 'frmPatient'I would like to add a new record for that patient in 'frmDSA' without closing the form.
On 'frmPatients' next to each record there is a button 'SaveNewRecord' that does the following:
(1)saves a new record to 'tblPatients' and also filters
(2) opens 'frmDSA' to display related records to that Patients.
Here is the filtering code:
If Not Me.NewRecord Then
DoCmd.OpenForm "DSAfrm", _
WhereCondition:="LABCODE=" & Me.LABCODE
End If
Here is what happens:
After the 'DSAfrm' pops up and I try to enter a new record I get the following error."can not add records joint key of table 'TableName' not in record-set"
The new patient has been save to 'tblPatients' but Access is not letting me add any new records. Please help!
Here is the code that I use to save the new records:
Private Sub Command385_Click()
Dim db As DAO.Database
Dim PatientTable As DAO.Recordset
Dim DSAtable As DAO.Recordset2
Dim errMsg As String 'Where we will store error messages
Dim errData As Boolean 'Default = False if we have an error we will set it to True.
Dim i As Integer 'used as a counter in For..Next loops.
Dim x As Integer 'used as counter in For..Next loops.
Dim errorArray(0 To 3) As String 'Array to hold the error messages so we can 'use them if needed.
If Me.LABCODE.Value = "" Then
errorArray(0) = "Must Enter Labcode."
errData = True
End If
If Me.LastName.Value = 0 Then
errorArray(1) = "Must Enter Patient Number"
errData = True
End If
If Me.FirstName.Value = "" Then
errorArray(2) = "Must Enter Insurance Type"
errData = True
End If
If Me.MRN.Value = "" Then
errorArray(3) = "Must Enter Intake Nurse"
errData = True
End If
'MsgBox "errData = " & errData
If errData = True Then
i = 0
x = 0
For i = 0 To 3
If errorArray(i) <> "" Then
If x > 0 Then
errMsg = errMsg & vbNewLine & errorArray(i)
Else
errMsg = errorArray(i)
x = x + 1
End If
End If
Next i
MsgBox errMsg & vbNewLine & "Please try again."
errMsg = ""
Me.LABCODE.SetFocus
Exit Sub
End If
Set db = CurrentDb()
Set PatientTable = db.OpenRecordset("tblPatients")
With PatientTable
.AddNew
!LABCODE = Me.LABCODE.Value
!LastName = Me.LastName.Value
!FirstName = Me.FirstName.Value
!MRN = Me.MRN.Value
!MRNTwo = Me.MRN2.Value
Debug.Print Me.MRN.Value
'!CPI#2 = Me.MRN2.Value
!Kidney = Me.cbKidney.Value
!Heart = Me.cbHeart.Value
!Lung = Me.cbLung.Value
!Liver = Me.cbLiver.Value
!Pancreas = Me.cbPancreas.Value
!DateLogged = Format(Date, "MM/DD/YY")
.Update
End With
'End If
Set DSAtable = db.OpenRecordset("tblDSA")
With DSAtable
.AddNew
!LABCODE = Me.LABCODE.Value
.Update
End With
'Let the user know it worked.
MsgBox "This patient has been added successfully.", vbOKOnly
'If Not Me.NewRecord Then
DoCmd.OpenForm "DSAfrm", _
WhereCondition:="LABCODE=" & Me.LABCODE
'End If
End Sub
I am using VB6 in my system. I want to pass the selected row value of a datagrid to the textbox and edit the record. But I'm getting this error every time I run the code. "Either BOF or EOF is True, or the current record has been deleted. Requested operation requires a current record." Here's my codes in update button. Please help. Thanks in advance! :D
Private Sub cmdEdit_Click()
Dim conn As New Connection
Dim myRS As New Recordset
Dim sql As Integer
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;DataSource=C:\Users\FSCNDCIT\Desktop\GSTD\GSTDdb.mdb"
myRS.CursorLocation = adUseClient
myRS.Open "SELECT * FROM Table1 WHERE ID = '" & DataGrid1.Text & "'", conn, adOpenDynamic, adLockBatchOptimistic
frmGoSee.txtID.Text = myRS!ID 'This line was highlighted.
frmGoSee.txtGSTD.Text = myRS!GSTDCode
frmGoSee.txtGSTDCode.Text = myRS!WorkGroup
frmGoSee.txtTL.Text = myRS!TL
frmGoSee.txtDeptHead.Text = myRS!DeptHead
frmGoSee.txtParticipants.Text = myRS!Participants
frmGoSee.txtCoach.Text = myRS!Coach
frmGoSee.txtProblem_Des.Text = myRS!Problem_Des
frmGoSee.txtMI.Text = myRS!MI
frmGoSee.txtInter_Correction.Text = myRS!Inter_Correction
frmGoSee.txtICWho.Text = myRS!ICWho
frmGoSee.txtICWhen.Text = myRS!ICWhen
frmGoSee.txtICStatus.Text = myRS!ICStatus
frmGoSee.lblpicture.Caption = myRS!Picture
frmGoSee.Image1.Picture = LoadPicture(lblpicture)
myRS.Update
Set myRS = Nothing
conn.Close
End Sub
The error is telling you that the query did not bring back any records. Your code just assumes there will be a record. You should check for an empty recordset before trying to assign values.
Private Sub cmdEdit_Click()
Dim conn As New Connection
Dim myRS As New Recordset
Dim sql As Integer
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;DataSource=C:\Users\FSCNDCIT\Desktop\GSTD\GSTDdb.mdb"
myRS.CursorLocation = adUseClient
myRS.Open "SELECT * FROM Table1 WHERE ID = '" & DataGrid1.Text & "'", conn, adOpenDynamic, adLockBatchOptimistic
If myRS.EOF = False Then
frmGoSee.txtID.Text = myRS!ID 'This line was highlighted.
frmGoSee.txtGSTD.Text = myRS!GSTDCode
frmGoSee.txtGSTDCode.Text = myRS!WorkGroup
frmGoSee.txtTL.Text = myRS!TL
frmGoSee.txtDeptHead.Text = myRS!DeptHead
frmGoSee.txtParticipants.Text = myRS!Participants
frmGoSee.txtCoach.Text = myRS!Coach
frmGoSee.txtProblem_Des.Text = myRS!Problem_Des
frmGoSee.txtMI.Text = myRS!MI
frmGoSee.txtInter_Correction.Text = myRS!Inter_Correction
frmGoSee.txtICWho.Text = myRS!ICWho
frmGoSee.txtICWhen.Text = myRS!ICWhen
frmGoSee.txtICStatus.Text = myRS!ICStatus
frmGoSee.lblpicture.Caption = myRS!Picture
frmGoSee.Image1.Picture = LoadPicture(lblpicture)
'Commented because nothing in the record has changed
'There is nothing to update
'myRS.Update
End If
'checking the state of your objects here before closing would be good practice
If Not myRS Is Nothing Then
If myRS.State = adStateOpen Then
myRS.Close
End If
Set myRS = Nothing
End If
If Not conn Is Nothing Then
If conn.State = adStateOpen Then
conn.Close
End If
Set conn = Nothing
End If
End Sub