Setting the recordset position to the currently active record in a continuous subform 1

[larrydavid]

Hello,

I am trying to use this function (courtesy of Allen Browne) to copy the currently selected record in a subform to a new record at the end. This function was written to copy only the last record. In the CarryOver function (shown below) I think the key at this point is to set the recordset pointer to the currently active record in the subform, wherever that may be, but I'm not sure how (or if) I can modify this code to do this.

Public Function CarryOver(frm As Form, strErrMsg As String, ParamArray avarExceptionList()) As Long
On Error GoTo Err_Handler

'Courtesy of Allen Browne
'Purpose: Carry over the same fields to a new record, based on the CURRENT record in the form.
'Arguments: frm = the form to copy the values on.
' strErrMsg = string to append error messages to.
' avarExceptionList = list of control names NOT to copy values over to.
'Return: Count of controls that had a value assigned.
'Usage: In a form's BeforeInsert event, excluding Surname and City controls:
' Call CarryOver(Me, strMsg, "Surname", City")

Dim rs As DAO.Recordset 'Clone of form.
Dim ctl As Control 'Each control on form.
Dim strForm As String 'Name of form (for error handler.)
Dim strControl As String 'Each control in the loop
Dim strActiveControl As String 'Name of the active control. Don't assign this as user is typing in it.
Dim strControlSource As String 'ControlSource property.
Dim lngI As Long 'Loop counter.
Dim lngLBound As Long 'Lower bound of exception list array.
Dim lngUBound As Long 'Upper bound of exception list array.
Dim bCancel As Boolean 'Flag to cancel this operation.
Dim bSkip As Boolean 'Flag to skip one control.
Dim lngKt As Long 'Count of controls assigned.

'Initialize.
strForm = frm.Name
strActiveControl = frm.ActiveControl.Name
lngLBound = LBound(avarExceptionList)
lngUBound = UBound(avarExceptionList)

'Make sure there is a record to copy.
If Not bCancel Then
Set rs = frm.RecordsetClone
If rs.RecordCount <= 0& Then
bCancel = True
strErrMsg = strErrMsg & "Cannot carry values over. Form '" & strForm & "' has no records." & vbCrLf
End If
End If

If Not bCancel Then
rs.MoveLast
'Loop the controls.
For Each ctl In frm.Controls
bSkip = False
strControl = ctl.Name
'Ignore the active control, those without a ControlSource, and those in the exception list.
If (strControl <> strActiveControl) And HasProperty(ctl, "ControlSource") Then
For lngI = lngLBound To lngUBound
If avarExceptionList(lngI) = strControl Then
bSkip = True
Exit For
End If
Next
If Not bSkip Then
'Examine what this control is bound to. Ignore unbound, or bound to an expression.
strControlSource = ctl.ControlSource
If (strControlSource <> vbNullString) And Not (strControlSource Like "=*") Then
'Ignore calculated fields (no SourceTable), autonumber fields, and null values.
With rs(strControlSource)
If (.SourceTable <> vbNullString) And ((.Attributes And dbAutoIncrField) = 0&) _
And Not (IsCalcTableField(rs(strControlSource)) Or IsNull(.Value)) Then
If ctl.Value = .Value Then
'do nothing. (Skipping this can cause Error 3331.)
Else
ctl.Value = .Value
lngKt = lngKt + 1&
End If
End If
End With
End If
End If
End If
Next
End If

CarryOver = lngKt

Exit_Handler:
Set rs = Nothing
Exit Function

Err_Handler:
strErrMsg = strErrMsg & Err.Description & vbCrLf
Resume Exit_Handler
End Function

Private Function IsCalcTableField(fld As DAO.Field) As Boolean
'Purpose: Returns True if fld is a calculated field (Access 2010 and later only.)
On Error GoTo ExitHandler
Dim strExpr As String

strExpr = fld.Properties("Expression")
If strExpr <> vbNullString Then
IsCalcTableField = True
End If

ExitHandler:
End Function

Public Function HasProperty(obj As Object, strPropName As String) As Boolean
'Purpose: Return true if the object has the property.
Dim varDummy As Variant

On Error Resume Next
varDummy = obj.Properties(strPropName)
HasProperty = (Err.Number = 0)

Any help would be greatly appreciated.

Thanks,
Larry

 

[PHV]

I'd get rid of this line:
rs.MoveLast

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[dhookom]

Larry,
Please attempt to use TGML to format your code blocks so the formatting is retained and your postings are easier to read. I have taken sections of your code to show the difference.

Public Function CarryOver(frm As Form, strErrMsg As String, ParamArray avarExceptionList()) As Long
        On Error GoTo Err_Handler

[COLOR=#4E9A06]	'Courtesy of Allen Browne
	'Purpose: Carry over the same fields to a new record, based on the CURRENT record in the form.
	'Arguments: frm = the form to copy the values on.
	' strErrMsg = string to append error messages to.
	' avarExceptionList = list of control names NOT to copy values over to.
	'Return: Count of controls that had a value assigned.
	'Usage: In a form's BeforeInsert event, excluding Surname and City controls:
	' Call CarryOver(Me, strMsg, "Surname", City")[/color]

	Dim rs As DAO.Recordset [COLOR=#4E9A06]'Clone of form.[/color]
	Dim ctl As Control [COLOR=#4E9A06]'Each control on form.[/color]

[COLOR=#4E9A06]	'Initialize.[/color]
	strForm = frm.Name
	strActiveControl = frm.ActiveControl.Name
	lngLBound = LBound(avarExceptionList)
	lngUBound = UBound(avarExceptionList)

	[COLOR=#4E9A06]'Make sure there is a record to copy.[/color]
	If Not bCancel Then
		Set rs = frm.RecordsetClone
		If rs.RecordCount <= 0& Then
			bCancel = True
			strErrMsg = strErrMsg & "Cannot carry values over. Form '" & strForm & "' has no records." & vbCrLf
		End If
	End If

Duane
Hook'D on Access
MS Access MVP

 

[larrydavid]

Hi PH and Duane,

Thank you both very much for the input. Yes, I will make sure to use TGML to format my code blocks in the future, sorry about that.

Larry

 

[larrydavid]

Still not working. I need to copy the record to the new record but it doesn't do this. I think I'm going to have to create a popup form and do it that way.

Thanks,
Larry

 

[dhookom]

Learn faq705-7148

Duane
Hook'D on Access
MS Access MVP