Public Function RepiteUltimo(frm As Form, strErrMsg As String, ParamArray avarExceptionList()) As Long
On Error GoTo Err_Handler
'Propósito: transferir los mismos campos a un nuevo registro, según el último registro del formulario.
'Argumentos: frm = el formulario para copiar los valores.
' strErrMsg = cadena para agregar mensajes de error.
' avarExceptionList = lista de nombres de control NO para copiar valores.
'Return: Conteo de controles que tenían un valor asignado.
'Uso: en el evento BeforeInsert de un formulario, excluyendo los controles de Apellido y Ciudad:
' Call RepiteUltimo(Me, strMsg, "Apellido", Ciudad")
Dim rs As DAO.Recordset 'Clon del formulario.
Dim ctl As Control 'Cada control del formulario.
Dim strForm As String 'Nombre del formulario (para el controlador de errores).
Dim strControl As String 'Cada control en el bucle
Dim strActiveControl As String 'Nombre del control activo. No asigne esto ya que el usuario lo está escribiendo.
Dim strControlSource As String 'Propiedad ControlSource.
Dim lngI As Long 'Contador del bucle
Dim lngLBound As Long 'Límite inferior de la matriz de la lista de excepciones.
Dim lngUBound As Long 'Límite superior de la matriz de la lista de excepciones.
Dim bCancel As Boolean 'Bandera para cancelar esta operación.
Dim bSkip As Boolean 'Marcar para omitir un control.
Dim lngKt As Long 'Recuento de controles asignados.
'Initialize.
strForm = frm.Name
strActiveControl = frm.ActiveControl.Name
lngLBound = LBound(avarExceptionList)
lngUBound = UBound(avarExceptionList)
'No debe asignar valores a los controles del formulario si no se encuentra en un nuevo registro.
If Not frm.NewRecord Then
bCancel = True
strErrMsg = strErrMsg & "No se pueden transferir valores. Formulario '" & strForm & "' no es un nuevo registro." & vbCrLf
End If
'Busque el registro para copiar, verificando que haya uno.
If Not bCancel Then
Set rs = frm.RecordsetClone
If rs.RecordCount <= 0& Then
bCancel = True
strErrMsg = strErrMsg & "No se pueden transferir valores. Formulario '" & strForm & "' no tiene registros." & vbCrLf
End If
End If
If Not bCancel Then
'El último registro del formulario es el que se va a copiar.
rs.MoveLast
'Hace un bucle con los controles.
For Each ctl In frm.Controls
bSkip = False
strControl = ctl.Name
'Ignore el control activo, aquellos sin ControlSource y aquellos en la lista de excepciones.
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 a qué está destinado este control. No haga caso de no enlazado o enlazado a una expresión.
strControlSource = ctl.ControlSource
If (strControlSource <> vbNullString) And Not (strControlSource Like "=*") Then
'Ignore los campos calculados (sin SourceTable), los campos de numeración automática y los valores nulos.
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
'hacer nada. (Omitir esto puede causar el error 3331).
Else
ctl.Value = .Value
lngKt = lngKt + 1&
End If
End If
End With
End If
End If
End If
Next
End If
RepiteUltimo = 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
'Propósito: Devuelve True si fld es un campo calculado (solo Access 2010 y versiones posteriores).
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
'Propósito: Devuelve verdadero si el objeto tiene la propiedad.
Dim varDummy As Variant
On Error Resume Next
varDummy = obj.Properties(strPropName)
HasProperty = (Err.Number = 0)
End Function
