Code works well in A97 and Xp, but bombs in A2000.

[Mark A. Sam]

Here is a procedure which produces a duplicate record in an order entry
program, along with subform data. It has worked well for years in A97 and I
have no problems in A2002, but A2000 bombs out. Sometimes I get a duplicate
index error, but lately get this and error "Action Cancelled by an
Associated Object".

It occurs on the line marked below: ******ERROR OCCURING ON NEXT LINE
It is an AddNew method.

I believe it is an issue with A2000. I don't have the service packs
installed and am unable to, but my clients does and has this problem, so I
don't think that is the issue.

Thanks for any help.


Private Sub Copy_Record_Click()
On Error GoTo error_Section

'This Procedure makes a complete copy of the current record, but of course
it assigns a new Order Number
'<<-- A Is a grouping indicator for If...Then statements to keep the code
neat
'Recordset will be set when needed and cleared when not needed
'Vaiables are Dimmed in the General Module of this form

Dim dbs As Database
Dim rsDef As Recordset
Dim strJob As String 'Order number value to pass to Dialogbox
Dim ctl As Control
Dim lngID As Long
Dim lngOrdID As Long
Dim lngDetID As Long
Dim fld As Field
Dim strCriteria As String
Dim strCriteriaOrd As String
'Dim dtShipDate As Date

'dtShipDate = InputBox("Enter New Scheduled Ship Date!" & vbCrLf & vbCrLf &
"Leave Blank to use Sheduled Ship Date of this order!", , Date)


Set dbs = CurrentDb
Set rsDef = dbs.OpenRecordset("defaults", dbOpenDynaset)

'Assign order number
rsDef.MoveFirst
strJob = rsDef![ordnum] 'Assign next Job Number from default table

'Open dialogbox to display next job number. ALso give user a chance to
change number
'Job number selected will be validated before dialogbox is closed
DoCmd.OpenForm "OrderNewNum", , , , , acDialog, strJob 'Open Dialogbox
'Job Number was checked and is available
If pubNewNum = -1 Then '<<--A Cancel button was pushed on dialogbox.
Set rsDef = Nothing
Set dbs = Nothing
'Exit Sub
GoTo exit_Section
Else '<<--A Create the record, assign new number to it and go to it.

DoCmd.openform "Action Message", , , , , , "Duplicating Order"
Forms![Action Message].Repaint
DoEvents

'Duplicate HEADER Info
Dim rsOrder As Recordset
Set rsOrder = Me.RecordsetClone
strCriteriaOrd = "[OrdJob] =" & pubNewNum


******ERROR OCCURING ON NEXT LINE
rsOrder.AddNew
rsOrder![ordJob] = pubNewNum 'New Order Number Assigned to record
rsOrder![ordRecordCommited] = True
rsOrder![Date Updated] = Date + Time
For Each ctl In Me.Controls
If Parse(ctl.Tag, 3, ";") = "Dup" Then '<<--B The Controls to be
transferred have same names as Order Entry controls
rsOrder.Fields(ctl.Name) = ctl
End If '<<--B
Next ctl
lngOrdID = rsOrder![OrdID]
' If Not IsNull(dtShipDate) Then
' rsOrder![ordShipdate] = dtShipDate
' End If
rsOrder![ordReqDate] = Null
rsOrder![ordShipdate] = Null
rsOrder![ordStartDate] = Null
rsOrder![ordPO] = Null
rsOrder.Update

rsDef.Edit
rsDef![ordnum] = pubNewNum + 1 'Reassign default Order Numner
rsDef.Update

Set rsOrder = Nothing 'Clear recordset from memory - Not needed Now, will
Re Set later
Set rsDef = Nothing 'Clear recordset form memory - Not needed

'Duplicate the SUBFORM Info
'1) Products
Dim rsDupProducts As Recordset 'Products new record
Dim rsOrderProds As Recordset 'Products current record
'Duplicate Product info
'Retrieve [OrdId] from New record and create Products record in Table
[Order Entry ST Products]
Set rsDupProducts = dbs.OpenRecordset("Order Entry ST Products",
dbOpenDynaset) 'Duplicated Products
Set rsOrderProds = [ Products].Form.RecordsetClone 'Products of current
record

rsOrderProds.MoveFirst
'Do Until rsOrderProds.EOF
Do Until rsOrderProds.EOF 'A<-- Loop Existing Products
rsDupProducts.AddNew 'B<-- Update New product
For Each fld In rsOrderProds.Fields
On Error Resume Next
If Left(fld.Name, 3) = "Det" Then '<<--C
If Parse([ Products].Form.Controls(fld.Name).Tag, 3, ";") = "Dup"
Then 'Check corrsponding field contol's tag
rsDupProducts.Fields(fld.Name) = fld
rsDupProducts![OrdID] = lngOrdID
End If
End If '<<--C

Next fld
On Error GoTo error_Section
lngDetID = rsDupProducts![ordDetID] 'Child Field Value to be assigned to
new matrerials record
'If Not IsNull(dtShipDate) Then
' rsDupProducts![detShipDate] = dtShipDate
'End If

rsDupProducts.Update 'B<-- Update New product here to allow related
records to be added in the subtables
'---------------------------------------------------------------
'Add Materials for this product
Dim rsDupMaterials As Recordset 'Materials new record
Dim rsProdMats As Recordset 'Materials current record
'Duplicate Product info
Set rsDupMaterials = dbs.OpenRecordset("Order Entry ST Materials",
dbOpenDynaset) 'Materials of Duplicated Products
Set rsProdMats = dbs.OpenRecordset("Order Entry ST Materials",
dbOpenDynaset) 'Material of current product record
lngID = rsOrderProds![ordDetID] 'Used to find current existing
Material
strCriteria = "[ordDetID] = " & lngID

rsProdMats.FindFirst strCriteria 'Find original material for this
product

Do Until rsProdMats.NoMatch 'C<-- Loop Existing Material

rsDupMaterials.AddNew
For Each fld In rsProdMats.Fields
On Error Resume Next
'*If Left(fld.Name, 4) = "Prod" Then '<<--C
If Parse([Materials].Form.Controls(fld.Name).Tag, 3, ";") = "Dup"
Then 'Check corrsponding field contol's tag
rsDupMaterials.Fields(fld.Name) = fld
End If
'*End If '<<--C
Next fld
On Error GoTo error_Section
rsDupMaterials![ordDetID] = lngDetID 'Assign value to child field
rsDupMaterials.Update
rsProdMats.FindNext strCriteria
Loop 'C<-- Loop Existing Material
Set rsDupMaterials = Nothing 'Clear recordset from memory
Set rsProdMats = Nothing 'Clear recordset from memory

'Add Tasks for this product
Dim rsDupTasks As Recordset 'Tasks new record
Dim rsProdTasks As Recordset 'Tasks current record
'Duplicate Product info
Set rsDupTasks = dbs.OpenRecordset("Order Entry ST Tasks",
dbOpenDynaset) 'Tasks of Duplicated Products
Set rsProdTasks = dbs.OpenRecordset("Order Entry ST Tasks",
dbOpenDynaset) 'Tasks of current product record
lngID = rsOrderProds![ordDetID] 'Used to find current existing
Material
strCriteria = "[ordDetID] = " & lngID

rsProdTasks.FindFirst strCriteria 'Find original material for this
product
Do Until rsProdTasks.NoMatch 'C<-- Loop Existing Material

rsDupTasks.AddNew
For Each fld In rsProdTasks.Fields
On Error Resume Next
If fld.Name <> "custProdTaskID" Then
If Parse([Tasks].Form.Controls(fld.Name).Tag, 3, ";") = "Dup" Then
'Check corrsponding field contol's tag
rsDupTasks.Fields(fld.Name) = fld
End If
End If
Next fld
On Error GoTo error_Section
rsDupTasks![prodTaskComplete] = False 'Clear this field for new entry
rsDupTasks![prodTaskEmpNo] = 0 'Clear this field for new entry
rsDupTasks![ordDetID] = lngDetID 'Assign value to child field
rsDupTasks![prodTaskDateComplete] = Null
rsDupTasks.Update
rsProdTasks.FindNext strCriteria
Loop 'C<-- Loop Existing Material
Set rsDupTasks = Nothing 'Clear recordset from memory
Set rsProdTasks = Nothing 'Clear recordset from memory


'Add Subcontract Services for this product
Dim rsDupServices As Recordset 'Services new record
Dim rsProdServs As Recordset 'Services current record
'Duplicate Product info
Set rsDupServices = dbs.OpenRecordset("Order Entry ST Subcontract
Services", dbOpenDynaset) 'Materials of Duplicated Products
Set rsProdServs = dbs.OpenRecordset("Order Entry ST Subcontract
Services", dbOpenDynaset) 'Services of current product record
lngID = rsOrderProds![ordDetID] 'Used to find current existing Services
strCriteria = "[ordDetID] = " & lngID
rsProdServs.FindFirst strCriteria 'Find original Service for this
product
Do Until rsProdServs.NoMatch 'C<-- Loop Existing Service

rsDupServices.AddNew
For Each fld In rsProdServs.Fields
On Error Resume Next
If fld.Name <> "subContID" Then
If Parse([Subcontract Services].Form.Controls(fld.Name).Tag, 3, ";")
= "Dup" Then 'Check corrsponding field contol's tag
rsDupServices.Fields(fld.Name) = fld
End If
End If
Next fld
On Error GoTo error_Section
rsDupServices![ordDetID] = lngDetID 'Assign value to child field
rsDupServices.Update
rsProdServs.FindNext strCriteria
Loop 'C<-- Loop Existing Service
Set rsDupServices = Nothing 'Clear recordset from memory
Set rsProdServs = Nothing 'Clear recordset from memory

'---------------------------------------------------------------
rsOrderProds.FindFirst "[ordDetID] = " & lngID
rsOrderProds.MoveNext 'A<-- Loop Existing Products
Loop
Set rsDupProducts = Nothing 'Clear recordset from memory
Set rsOrderProds = Nothing 'Clear recordset from memory


'2)Tech Specs
Dim rsDupTechs As Recordset 'TechSpecs new record
Dim rsOrderTechs As Recordset 'TechSpecs current record
'Duplicate Technical info
Set rsDupTechs = dbs.OpenRecordset("Order Entry Technical Specs",
dbOpenDynaset) 'Duplicated Technical Specs
Set rsOrderTechs = [tech specs].Form.RecordsetClone 'Technical Specs of
current record
strCriteria = "[OrdID] = " & [OrdID]
rsOrderTechs.FindFirst strCriteria
'Do Until rsOrderTechs.EOF 'A<-- Loop Existing Technical Specs
rsDupTechs.AddNew 'B<-- Update New Technical Specs
For Each fld In rsOrderTechs.Fields
On Error Resume Next
'If Left(fld.Name, 3) = "Det" Then '<<--C
If fld.Name <> "ordTspecID" Then
rsDupTechs.Fields(fld.Name) = fld
rsDupTechs![OrdID] = lngOrdID
End If
'End If '<<--C

Next fld
On Error GoTo error_Section
rsDupTechs.Update 'B<-- Update New product here to allow related records
to be added in the subtables

'Loop
Set rsDupTechs = Nothing
Set rsOrderTechs = Nothing


'Find new Order on form
Set rsOrder = Me.RecordsetClone
strCriteriaOrd = "[ordID] =" & lngOrdID 'Reset strCriteriaOrd
rsOrder.FindFirst strCriteriaOrd
If Not rsOrder.NoMatch Then
pubNoRequery = True 'Prevent subforms in Order Entry from getting caught
in loop in CurrentEvent
Me.Bookmark = rsOrder.Bookmark
pubNoRequery = False
End If
[ordCustID].SetFocus



'Populate Shipping Info defaults from Customer Profile
Dim rs As Recordset

Set dbs = CurrentDb()
Set rs = dbs.OpenRecordset("Customers", dbOpenDynaset)
strCriteria = "[custID] = " & [ordCustID]

rs.FindFirst strCriteria
If Not rs.NoMatch Then 'Record was found so assign values to form
controls.
[ordCarrierName1] = rs![Ccarrier1]
[ordCarrierMethod1] = rs![Servtyp1]
If Not IsNull(rs![Ccarrier1]) And rs![Ccarrier1] <> "" Then
[ordCarrierTime] = DLookup("CarrierTime", "Carriers", "[CarrierName]
= '" & rs![Ccarrier1] & "'")
End If
'Rich wanted time brought over, and there was no good way to address
CarrierID so Carriername was
'used which is a Non Duplicate value, so acceptable.
[ordShipAccount1] = rs![Caccount1]
[ordCustFreightPaymentType] = rs![CustFreightPaymentType1]
'[ordShipSpecInst1] = rs![Dremarks] **Not storing default value- Only
new info
End If


End If '<<--A




exit_Section:
On Error Resume Next
DoCmd.Close acForm, "Action Message"
Set rsOrder = Nothing
Set rsDef = Nothing
Set rsDupProducts = Nothing
Set rsOrderProds = Nothing
MsgBox "New Order Created Successfully"
Exit Sub

error_Section:
MsgBox Err.Description
'Resume exit_Section
Stop
Resume Next

End Sub

 

[Mark A. Sam]

Here is another oddity: This code is in a subform on current event. It
sets the values for unbound textboxs on the Parent, which are the
LinkMasterFields for two other subforms.

On Error GoTo error_Section

Parent.[ProdCodecalc5] = [prodCode]
Parent.[MaterialLists5] = Nz([prodMatListID], 0)

exit_Section:
Exit Sub

error_Section:
MsgBox "Error Number " & Err & ": " & Err.Description
Resume Next

The code hangs up on the first line. Error Number 2448: You cannot assign a
value to this object.

[ProdCodecalc5] exists and is unbound. I replaced that Textbox with a new
one to rule out corruption. I also created a new db and imported all of the
objects into it compiled it in A2000 and got the same result. .

I am developing this using A2002, but the get the same results from Access
2000.

The parent form is a subform, but this same method if repeated on 4 others
subforms which are nested a couple more levels in, and with no problem.

This is puzzling me and I need to get it resolved, so any ideas on what is
causing this is appreciated.

God Bless,

Mark A. Sam

 

[Mark A. Sam]

I placed a new textbox called [test] on the Parent for then modified to
code to assign the value to that control instead of [ProdColdcalc5] with the
same result.

Then I tried:

Dim ctl As Control
Set ctl = Parent.[test]
ctl = prodCode


Which Yielded this error: Runtime error '2465': Microsoft Access cannot
find the field '|' referred to in your expression.

In the immediate window,

?Parent.[test] yields the same error

?Parent.[ProdCodecalc5] Yields Run time error '2447': There is an invalid
use of the . (dot) or ! operator or invalid parentheses

?Parent.[ProdCodecalc5].controltype Yields 109

?Parent.[test] Yields Run-Time error '2452': The expression you entered has
an invalid reference to the Parent property.

Thanks,

Mark A. Sam

 

[Mark A. Sam]

Never mind. I believe there is corruption in the form. I converted it to
A97 and got an Illegal Action dialog box when I opened the form.

God Bless,

Mark A. Sam

 

[Marshall Barton]

Never mind. I believe there is corruption in the form. I converted it to
A97 and got an Illegal Action dialog box when I opened the form.

As I had no idea what the problem could be, it's a relief to
hear that it's "just" a corruption issue. At least you know
what to do now ;-)

 

[Mark A. Sam]

Marshall,

Actually is wasn't corruption after all, but if it was, I wouldn't have
known what to do.

I had two problems. This is a very complex form which I developed over the
years. I has many levels of nested forms and tab controls. I had forgotten
that I removed a subform section within a tabpage and put the controls
directly into the page. I was modifying the subform, which was doing
nothing, becuase it was no longer used. A second problem was parameters in
queries. The redeesign of the system required me to change those
parameters, which I missed.

Finally it is smooth and working fine.

Thanks and God Bless,

Mark

 

[Marshall Barton]

Marshall,

Actually is wasn't corruption after all, but if it was, I wouldn't have
known what to do.

I had two problems. This is a very complex form which I developed over the
years. I has many levels of nested forms and tab controls. I had forgotten
that I removed a subform section within a tabpage and put the controls
directly into the page. I was modifying the subform, which was doing
nothing, becuase it was no longer used. A second problem was parameters in
queries. The redeesign of the system required me to change those
parameters, which I missed.

Finally it is smooth and working fine.

Thanks and God Bless,

Well, everyone always says the toughest problems are in
modifying old code (even if you're the one that wrote it).

I'm still glad you worked it all out in the end.

As for knowng what to do with corrupted dbs,
"Restore From Backup" of course ;-)

Seriously, there's a very nice summary of corruptions at
Tony Toews' site:
http://www.granite.ab.ca/access/corruptmdbs.htm

 

[Synergy]

For anyone who encounters this issue I resolved this by changing a recordset
reference from the form's recordsetclone, directly to the table which the
form addresses.

From

Set rsOrder = Me.RecordsetClone
To

Set rsOrder = dbs.OpenRecordset("Order Entry Header", dbOpenDynaset)

 

[Peter De Baets]

This is a DAO/ADO issue. The RecordsetClone method always returns a DAO
recordset object, even if you are using Access 2000/ADO with no DAO
reference at all. It's weird, I know, but that's how Access 2000 works.

You probably could have resolved the problem by referencing DAO and
assigning the RecordsetClone to a DAO recordset object.

Hope this helps,