Re: Jet 3.51 transaction success rate

Andy,

Looks like the problem is the .AddNew within your RTS2 recordset loop, which
might cause the new record to become part of that RTS2 recordset.

With RTS2
.Edit
!DateEnd = Now()
.Update

.AddNew
...add data to fields
.Update
End With


If so, all you need to do is initialize another recordset:

Set RTS3 = db.openRecordset("tblDptOwnerHist")
With RTS2
.Edit
!DateEnd = Now()
.Update

RTS3.AddNew
...add data to fields
RTS3.Update
End With
RTS3.Close




Andy_Khosravi@xxxxxxxxxx wrote:
I'm an entry-level VBA programmer that is almost entirely self-taught.
This means that while I have adequate knowledge of VBA in some areas,
I have several gaps in others that may seem obvious to more
experienced programmers. Please bear with me =)

I'm having a problem that occurs intermittently (about 1 error per
1,000 transactions) with a routine I wrote. It would seem that the
recordset command to .addnew is for whatever reason adding multiple
records. My primary suspicion is that it is my code causing the
problem, but I wanted to make sure there were no known issues with the
Jet 3.51 engine (I'm using A97). I've noticed while maintaining the
database that there are a few isolated examples where the code seems
to have failed in other routines. (Usually occurrences are around
1/5,000 - 1/10,000)

What kind of success rate do these transactions normally have? Do you
more experienced programmers typically put in any double checks to
insure transactions went through? If so, what's the best way to do
that?

The above is my primary question. However, if any of you are feeling
particularly bored, (And you'll need to be, It's a lot of code) I've
also included the code for the routine I'm having trouble with. I
can't seem to find where the code could be looping several times to
allow for the duplicate entries.

Thanks in advance for any help any of you may give!

The purpose of the routine is to 'move' an 'issue' from one location
to another. I.E. I have one table for issues and another table for
locations. One issue may have many locations. The routine essentially
date stamps the end time on the current location and then creates a
new record for the new location.

The form is set up in three sections. The top section contains blank
fields for the new location, the middle section contains the current
location (populated via recordset), while the lower sub form contains
a list of all past locations (populated by standard datasource set to
show all past locations excluding the current location). When the Send
button is pushed, the data from the new location is added to the
tables, and the form is repopulated to reflect the latest changes.

Code is below:

Private Sub Command66_Click()
'The first round of validation checks below insure that the current
user is eligible to move the issue
'Only an individual from the originating department or the current
department may move an item
'The exception to the above rule is for issues originating from
Service or Claims, in which case individuals
'from the key department (Operations Improvement Team) may also move
the issue at will.
'In addition to the above rules, a closed issue may not be moved
unless it is first re opened.

Dim MSX As String
If Status = "Closed" Then
MSX = MsgBox("You cannot move an issue that is closed.",
vbOKOnly, "Forward Issue")
Exit Sub
Else
If OriginatorDPT <> Forms!frmmainmenu!UserDepartment Then
If CurrentDepartment <> Forms!frmmainmenu!UserDepartment
Then
If OriginatorDPT = "Claims" Or OriginatorDPT =
"Service" Then
If Forms!frmmainmenu!UserDepartment <>
DLookup("department", "tbldepartments", "keydepartment = true") Then
Beep
MSX = MsgBox("You cannot move a piece that
your department did not originate OR that your department does not
currently own.", vbOKOnly, "Forward Issue")
Exit Sub
End If
Else
Beep
MSX = MsgBox("You cannot move a piece that your
department did not originate OR that your department does not
currently own.", vbOKOnly, "Forward Issue")
Exit Sub
End If
End If
End If
End If

'the subreason combo box may or may not be visible depending on if the
parent reason has any sub reasons.
'In the event that the sub reason is visible, an entry in that combo
box is required.
If NewSubReason.Visible = True Then
If IsNull(NewSubReason) Then
Beep
MSX = MsgBox("Sub Reason cannot be left blank", vbOKOnly,
"Forward Issue")
NewSubReason.SetFocus
Exit Sub
End If
End If

'This check insures that the issue is not being moved to the same
exact owner that currently has it. It
'also insures that issues that are currently assigned to a default
owner can't leave the department; all
'issues must first be assigned to a specific owner before they may
leave a department.
If NewOwnerID = CurOwnID Then
Beep
MSX = MsgBox("The New Owner can't be the same as the Current
Owner.", vbOKOnly, "Forward Issue")
NewOwnerID.SetFocus
Exit Sub
Else
If CurOwnID = "1" Then
If Me.CurrentDepartment <> Me.NewDepartment Then
Beep
MSX = MsgBox("You cannot move an issue to a new
Location until it has first been assigned to a specific individual
within its current Location. To do this, first assign the issue to a
specific individual in its current location, then from there move it
again to your intended destination.", vbOKOnly, "Forward Issue")
Exit Sub
End If
End If
End If

'this round of validations verifies that the user wants to actually
send the issue, and then insures that all
'required fields are filled in before allowing the move.
Beep
MSX = MsgBox("Are you sure you wish to forward this issue to a new
department?", vbYesNo, "Forward Issue")
Select Case MSX
Case vbYes
If IsNull(NewDepartment) Or NewDepartment = "" Then
Beep
MSX = MsgBox("You must select a valid location before
you can continue.", vbOKOnly, "Location cannot be blank")
NewDepartment.SetFocus
Exit Sub
Else
If IsNull(NewOwnerID) Or NewOwnerID = "" Then
Beep
MSX = MsgBox("You must select a valid owner from
the list before you can continue. If you do not know who to send it to
select 'Unassigned' from the pulldown menu.", vbOKOnly, "Owner cannot
be blank.")
NewOwnerID.SetFocus
Exit Sub
Else
If IsNull(NewReason) Or NewReason = "" Then
Beep
MSX = MsgBox("You must select a valid reason
for the move before you can continue.", vbOKOnly, "Reason cannot be
blank")
NewReason.SetFocus
Exit Sub
End If
End If
End If
Case vbNo
Exit Sub
End Select

'at this point all validations and verifications are completed. the
routine to actually execute the move is
'initiated.
'First, the current location is queried into a recordset.
'Next, an end date is inserted into the Date End field to time stamp
issue departure time.
'After that, a new record is created and appropriate fields are
populated. The date end field will be null.

Set RTS2 = db.OpenRecordset("SELECT * FROM tblDptOwnerHist WHERE
histID = " & CurrentHistID)

With RTS2
.Edit
!DateEnd = Now()
.Update

.AddNew
SetSubDPT1
If IsNull(IssueID) Then
!IssueID = Forms!Frmmainoperations!tblBenIssue1.IssueID
Else
!IssueID = IssueID
End If
!Department = NewDepartment
!OwnerID = NewOwnerID
!DateBegin = Now()
!Reason = NewReason
!SubReason = NewSubReason
!SubDepartment = NewSubDPT
!Mover = NewMover
If NewDepartment = CurrentDepartment Then
!ChangeID = ChangeID
Else
!ChangeID = Nz(ChangeID) + 1
Forms!Frmmainoperations!CurrentTOTDate = Date
End If
.Update
End With

'The Main Detail screen is then updated to show the current status of
the issue.
'These data fields hold duplicate data and are not normalized. These
fields were denormalized
'to simplify building the search form, and also on the off chance that
they would improve performance by
'eliminating a table join.
Forms!Frmmainoperations!CurrentOwner = NewOwnerID
Forms!Frmmainoperations!CurrentLocation2 = NewDepartment
Forms!Frmmainoperations!CurrentStartDate = Now()
Forms!Frmmainoperations!CurrentRSN = NewReason
'similar process as above, but insuring that the NewSubDPT is never
null. Fields that are referenced on the
'search form must either contain a value or a zero length string in
order to work properly
If IsNull(NewSubDPT) Then
NewSubDPT = ""
End If
Forms!Frmmainoperations!CurrentSubDPT = NewSubDPT

'The Main Detail form also contains a field which holds the overall
status of the issue. This is determined
'by reading certain flagged reasons during an issue movement
If Me.NewReason = "Not a Coding Error" Then
Forms!Frmmainoperations!RTNRSN = "Disagree"
Else
If Me.NewReason = "Coding Correction Completed" Then
Forms!Frmmainoperations!RTNRSN = "Agree"
End If
End If

DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, ,
acMenuVer70

Dim OutputType As String
If NewDepartment = "Sales/Marketing" Then
OutputType = "RichTextFormat(*.rtf)"
'DoCmd.SendObject acReport, "rptmainsingle", acFormatRTF, "",
"", "", "", "", True, ""
DoCmd.SendObject acReport, "rptmainsingle", acFormatRTF, , , ,
, , True
Else
If NewDepartment = "Claims" Or NewDepartment = "Service" Then
If Me.NewReason = "Not a Coding Error" Then
OutputType = "RichTextFormat(*.rtf)"
'DoCmd.SendObject acReport, "rptmainsingle",
acFormatRTF, "", "", "", "", "", True, ""
DoCmd.SendObject acReport, "rptmainsingle",
acFormatRTF, , , , , , True
End If
End If
End If

'The locations change form is now reset to display the most current
information.
Populater
Me.Requery
NewIssueID = ""
NewDepartment = ""
NewOwnerID = ""
NewReason = ""
NewSubReason = ""
NewSubReason.Visible = False
DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, ,
acMenuVer70
Me.Requery
End Sub


.