Form to update Access table

[gcarpenter]

I have a form that is linked to a table named Claims. Works great, I have an add Claim form and form to lok at unsettled and settled claims.

What I want to do is create another form that will update some of the fields in the table without opening the settled, Add, or unsettled forms. This would only update 2-3 fields in the table.

I have a good understanding of VBA and have several modules in this accdb database.

 

[theDBguy]

Hmm, just create the form you want with the fields you want to update and open it when you need to update them. To open the form using code, you can use DoCmd.OpenForm "FormName" or use a macro.

 

[Ranman256]

I have a continuous form that shows all records. A combo box 'filter' (via table) on the screen will change the data when user picks from it
CAPTION, QRY
All recs, qsAllRecs
Unsettled, qsUnsettled
Settled, qsSettled

when user picks the caption the code assigns the query to the List form, in AfterUpdate event.
me.recordsource = cboBox

this way users can decide what list to view.
Add an ADD NEW button to open a 'single record' form to enter new data.

 

[Pat Hartman]

It is far better to have a single form to update a single table. That way, all your logic is in one place and you don't have to worry about duplicating it in multiple forms.

If you have different rules for what can be updated for any particular status, you can still implement that in a single form.

 

[gcarpenter]

I have the update form built and working greater, no errors and updates the correct record, but if I open the form that has all bound controls and make a change in any of the controls, I get the dreaded 3251 error, Object not supported if I move to the next record.

 

[Pat Hartman]

You'll need to post the db or share the code behind the form.

 

[gcarpenter]

Here is the code for the form, every control on the form is bound to the table named CLAIMS.
Option Compare Database
Option Explicit
Dim RetVal As Variant
Dim rs As DAO.Recordset
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Private Sub CARRIERCODE_AfterUpdate()
On Error GoTo Err_CARRIERCODE
'populate carrier name field
Dim db As DAO.Database
Dim rs As DAO.Recordset, qd As QueryDef
Set db = CurrentDb
Set qd = db.CreateQueryDef("")
qd.SQL = "Select CARRIERNAME from CARRIER where CARRIERCODE = '" & Trim(CARRIERCODE) & "'"
Set rs = qd.OpenRecordset(Dynaset)
If rs.RecordCount = 0 Then
MsgBox "Carrier code: '" & Trim(CARRIERCODE) & "' not found in the database."
Else
cmbCarrier = rs(0)
End If
Exit_CARRIERCODE:
Exit Sub
Err_CARRIERCODE:
If Err.Number <> 3251 Then
MsgBox Err.DESCRIPTION
Else
Resume Exit_CARRIERCODE
End If
End Sub

'Private Sub CARRIERFB_AfterUpdate()
'Me.cbmHAWB.Requery
'End Sub
Private Sub cmbCarrier_AfterUpdate()
CARRIERCODE = cmbCarrier.Column(0)
End Sub
Private Sub cmdClaimReport_Click()
Dim stDocName As String
On Error GoTo Err_cmdPrintEntry_Click

If Me.NewRecord And Not Me.Dirty Then
MsgBox "No information has been entered for this claim."
Exit Sub
End If

If IsNull(SENTDATE) Then
SENTDATE = Date
End If

If Me.Dirty Then
DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
End If
strReportSource = "Select Carrier Claim"
stDocName = "Claims Report"
DoCmd.OpenReport stDocName, acNormal

Exit_cmdPrintEntry_Click:
Exit Sub

Err_cmdPrintEntry_Click:
If Err.Number <> 3251 Then
MsgBox Err.DESCRIPTION
Else
Resume Exit_cmdPrintEntry_Click

End If

End Sub

Private Sub cmdFileReport_Click()
On Error GoTo Err_cmdPrintEntry_Click

If Me.NewRecord And Not Me.Dirty Then
MsgBox "No information has been entered for this claim."
Exit Sub
End If

If Me.Dirty Then
DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
End If
Dim stDocName As String
strReportSource = "Select File Claim"
stDocName = "File Report"
DoCmd.OpenReport stDocName, acNormal

Exit_cmdPrintEntry_Click:
Exit Sub

Err_cmdPrintEntry_Click:
If Err.Number <> 3251 Then
MsgBox Err.DESCRIPTION
Else
Resume Exit_cmdPrintEntry_Click

End If
End Sub

Private Sub Combo309_AfterUpdate()
On Error GoTo err_Update

If Me.DATECLOSED > 0 Then
Me.Label86.Caption = "Date Delivered"
Me.Label76.Caption = "Days In Transit"
Me.ACKNUMBER.VALUE = (Date - [SHIPDATE])
Else:
Label86.Caption = "Days to Deliver"
Label76.Caption = "Days In Transit"
Me.ACKNUMBER.VALUE = (SHIPDEPT - [DATECLOSED])
exit_sub:
Exit Sub

err_Update:
If Err <> 3251 Then
Exit Sub
Resume Next
MsgBox "Your changes were not saved."
' Cancel = True
Resume exit_sub
End If
End If
End Sub

Private Sub DATECLOSED_AfterUpdate()
If IsNull(DATECLOSED) Then
CLAIMSTATUS = "OPEN"
Else
CLAIMSTATUS = "CLOSED"
End If
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
Call AuditTrail(Me, CLAIMENTRY)
On Error GoTo err_Update
Dim strClaimNo As String
MODDATE = Date
'check for required fields
If IsNull(Me!CARRIERCODE) Then
MsgBox "The carrier code is a required item."
Cancel = True
CARRIERCODE.SetFocus
Exit Sub
End If

If IsNull(Me!REPID) Then
'should never happen, but you never know...
MsgBox "This claim cannot be saved. The claim rep id is missing."
Cancel = True
Exit Sub
End If

' If IsNull(Me!SHIPDEPT) Then
' MsgBox "The SBU is a required item."
' Cancel = True
' SHIPDEPT.SetFocus
' Exit Sub
' End If

If IsNull(Me!CLAIMTYPE) Then
MsgBox "The claim type is a required item."
Cancel = True
CLAIMTYPE.SetFocus
Exit Sub
End If

'end of required data items.
exit_sub:
Exit Sub
Resume Next
err_Update:
If Err <> 3251 Then
MsgBox Err.DESCRIPTION
Else
MsgBox "Your changes were not saved."
Cancel = True
Resume exit_sub
End If
End Sub

Private Sub Form_Close()
DoCmd.SetWarnings True
RetVal = SysCmd(5)
DoCmd.Restore
Call LogDocClose(Me)
End Sub

Private Sub Form_Open(Cancel As Integer)

RetVal = SysCmd(4, "This is the form that contains all Air Freight, browse through the Freight with the navigation buttons at the bottom....")
Call LogDocOpen(Me)
'Dim AMOUNTCLOSED As Date
'If Forms![claims browse]![claims detail]![Claims.Browse]!AMOUNTCLOSED > 0 Then
'Me.Command283.Caption = "Preview Air Freight Report"
'Else:
'Me.Command283.Caption = "Preview Freight Report"
'End If
End Sub

Sub cmdUndo_Click()
On Error GoTo Err_cmdUndo_Click

If Me.Dirty Then
DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
Else
MsgBox "There are no active edits to undo on this claim."
End If

Exit_cmdUndo_Click:
Exit Sub

Err_cmdUndo_Click:
If Err.Number <> 3251 Then
MsgBox Err.DESCRIPTION
Else
Resume Exit_cmdUndo_Click

End If

End Sub
Sub cmdMarkCancel_Click()
On Error GoTo Err_cmdMarkCancel_Click

Dim Response As Integer
'If Me.NewRecord Then
'If Me.Dirty Then
' Response = MsgBox("This claim has not yet been saved. Do you wish to cancel the changes you've made?", vbYesNo, "Confirm Undo")
' If Response = vbYes Then
' DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
' End If
' Else
' MsgBox "No information has been entered for this claim."

'End If
' Else
' Response = MsgBox("Please confirm that you wish to mark this claim as 'Cancelled.'", vbYesNo, "Confirm Status Change")
' If Response = vbYes Then
' Me!CLAIMSTATUS = "CANCELLED"
' End If
'End If

Exit_cmdMarkCancel_Click:
Exit Sub
Err_cmdMarkCancel_Click:
If Err.Number <> 3251 Then
MsgBox Err.DESCRIPTION
Else
Resume Exit_cmdMarkCancel_Click
End If

End Sub

Sub cmdClose_Click()
On Error GoTo Err_cmdClose_Click
' Dim Response As Integer
'If Me.Dirty Then
' Response = MsgBox("Changes have been made to this claim. Do you wish to save these changes?", vbYesNoCancel, "Save Changes?")
' If Response = vbNo Then
' DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
'ElseIf Response = vbCancel Then
' Exit Sub
' End If
' End If

DoCmd.Close
Call LogDocClose(Me)

Exit_cmdClose_Click:
Exit Sub

Err_cmdClose_Click:
If Err.Number <> 3251 Then
MsgBox Err.DESCRIPTION
Else
Resume Exit_cmdClose_Click

End If

End Sub
Sub cmdSave_Click()
On Error GoTo Err_cmdSave_Click
DoCmd.SetWarnings False

'If Me.Dirty Then
' DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
' MsgBox "Claim saved."
'Else
' If Me.NewRecord Then
' MsgBox "No information has been entered for this claim."
' Else
DoCmd.Save
MsgBox "Air Freight Report saved."
' Me.Refresh
' End If
'End If

Exit_cmdSave_Click:
Exit Sub

Err_cmdSave_Click:
If Err.Number <> 3251 Then
MsgBox Err.DESCRIPTION
Else
Resume Exit_cmdSave_Click

End If
DoCmd.SetWarnings True
End Sub
Private Sub Command282_Click()
DoCmd.OpenForm "Print Email", acNormal, , , , acDialog, 0

End Sub
Private Sub Command283_Click()
On Error GoTo Err_Command283_Click

Dim stDocName As String
'HERE
strReportSource = "Select File Claim"

'TO HERE
stDocName = "File Report"
DoCmd.OpenReport stDocName, acPreview

Exit_Command283_Click:
Exit Sub

Err_Command283_Click:
MsgBox Err.DESCRIPTION
Resume Exit_Command283_Click

End Sub

Private Sub NextRecord_Click()
On Error GoTo ErrHandler
If Recordset.EOF Then
Beep
MsgBox "You are at the end of records."
DoCmd.GoToRecord , , acFirst
Else
DoCmd.GoToRecord , , acNext
End If
'DoCmd.GoToRecord , Record:=acNext, Offset:=1

Retry:
Exit Sub
Resume Next
ErrHandler:
Select Case Err.Number
Case Is = "2501"
GoTo Retry
Case Else
MsgBox "Error number - " & Err.Number & vbCrLf & Err.DESCRIPTION

Sleep 5
GoTo Retry
Resume

End Select
End Sub

Private Sub PreviousRecord_Click()
On Error GoTo ErrHandler
If Recordset.BOF Then
Beep
MsgBox "You are at the beginning."
DoCmd.GoToRecord , , acNext
Else
DoCmd.GoToRecord , , acPrevious
End If
'DoCmd.GoToRecord , Record:=acPrevious, Offset:=1

Retry:
Exit Sub
Resume Next
ErrHandler:
Select Case Err.Number
Case Is = "2501"
GoTo Retry
Case Else
MsgBox "Error number - " & Err.Number & vbCrLf & Err.DESCRIPTION

Sleep 5
GoTo Retry
Resume

End Select

End Sub

Private Sub SUBCODE_AfterUpdate()
Me.Refresh

End Sub

 

[Pat Hartman]

Let's try again please. When you post code, use the code tags so we don't have to look at long procedures with random line spacing and all left alignment. Also, at least tell us what procedure the error is happening in.

When you get the error message, press cntl-break to stop the code and look at it to find out where the error message is coming from.

1. you don't seem to be doing the validation in an appropriate event so Access could be trying to save invalid data. Validation code belongs in the form's BeforeUpdate event. You can either embed the code or you can call procedures but do not do validation in other form events. Sometimes you might want to do validation in a control's BeforeUpdate event so you can keep the user from going any further if he enters a duplicate value but you still need validation for that field in the form level event as well.
2. you have not given controls meaningful names. Who knows what Command283 is supposed to do?
3. Remove commented code once you finish testing so you know you are keeping the new code. The meaningless comment lines just make the code harder to read. If you feel you must keep the code, at lest tab it at least 20 characters in so it doesn't distract from what is going on.
4. I'm not sure why you are opening recordsets. It looks like you could use DCount() if all you are trying to do is determine if something exists.
5. And finally, I think you can't use rs.FindFirst on a linked table but I wouldn't swear to it since I never do this in a bound form.

 

[gcarpenter]

Pat, thank you for the tips, I'm fairly new to VBA, so I see my code was a mess. I did found the error in the below code. I think I used the code tags correctly, if not please inform me.

Sub AuditTrail(frm As Form, RecordID As Control)
'Track changes to data.
'recordid identifies the pk field's corresponding
'control in frm, in order to id record.
Dim ctl As Control
Dim varBefore As Variant
Dim varAfter As Variant
Dim strControlName As String
Dim strSQL As String
On Error GoTo ErrHandler
'Get changed values.
For Each ctl In frm.Controls
With ctl
'Avoid labels and other controls with Value property.
If .ControlType = acTextBox Then
If .VALUE <> .OldValue Then
varBefore = .OldValue
varAfter = .VALUE
strControlName = .NAME

'Build INSERT INTO statement.
strSQL = "INSERT INTO " _
& "Audit (EditDate, User, RecordID, SourceTable, " & " SourceField, BeforeValue, AfterValue) " & "VALUES (Now()," & cDQ & Environ("username") & cDQ & ", " & cDQ & RecordID.VALUE & cDQ & ", " & cDQ & frm.RecordSource & cDQ & ", " _
& cDQ & .NAME & cDQ & ", " & cDQ & varBefore & cDQ & ", " & cDQ & varAfter & cDQ & ")"
'View evaluated statement in Immediate window.
Debug.Print strSQL
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
End If
End With
Next
Set ctl = Nothing
Exit Sub
ErrHandler:
MsgBox Err.DESCRIPTION & vbNewLine & Err.Number, vbOKOnly, "Error"
End Sub

 

[Pat Hartman]

When you write code, it is far easier to read if you indent it logically.

I can't tell what the error you found is.

For Each ctl In frm.Controls
    With ctl
        'Avoid labels and other controls with Value property.
    If .ControlType = acTextBox Then
        If .VALUE <> .OldValue Then
            varBefore = .OldValue
            varAfter = .VALUE
            strControlName = .NAME
            'Build INSERT INTO statement.
            strSQL = "INSERT INTO " _
            & "Audit (EditDate, User, RecordID, SourceTable, " & " SourceField, BeforeValue, AfterValue) " & "VALUES (Now()," & cDQ & Environ("username") & cDQ & ", " & cDQ & RecordID.VALUE & cDQ & ", " & cDQ & frm.RecordSource & cDQ & ", " _
            & cDQ & .NAME & cDQ & ", " & cDQ & varBefore & cDQ & ", " & cDQ & varAfter & cDQ & ")"
            'View evaluated statement in Immediate window.
            Debug.Print strSQL
            DoCmd.SetWarnings False
            DoCmd.RunSQL strSQL
            DoCmd.SetWarnings True
        End If
    End If
End With
Next