Usar parámetros guardados en tabla en las aplicaciones de access
Pregunta
¿Podemos recuperar los datos del último registro abierto de un formulario?
Respuesta
Cuando volvemos a abrir un formulario que habíamos utilizado anteriormente, generalmente es práctico recuperar ciertos valores que se teclearon o seleccionaron en lugar de resetear el formulario obligando a repetir dicha selección. Eso lo podemos conseguir guardando esos valores a mantener y al abrir el formulario asignarlos a sus controles correspondientes.
A estos valores les denominé Parámetros, como a los valores que utilizamos para configurar una aplicación.
En esta propuesta se utiliza la tabla cfgParam para guardar los Parámetros, en dicha tabla encontramos el campo NP que es el Nombre del parámetro y es Clave Principal (no puede haber 2 iguales), el campo TipoDato con los posibles valores de 1=Boolean, 4=Long, 5=Currency, 8=Date, 10=Text(255) y 12=Memo. El campo VP guarda el valor del parámetro cuando TipoTexto = 10 y el resto de campos VPbool, VPlng, VPcur, VPmemo y VPfecha guardan los valores que les corresponden. Este pequeño lío tal vez no sea necesario y se podrían haber guardado todos los valores en VP (salvo los Memo muy grandes) pero salió así y así se quedó y tampoco ha ocasionado mayor problema.
En el módulo basParam de este ejemplo encontramos las funciones SetParam(sNP) y GetParam(sNP) que se encargan respectivamente de grabar y recuperar un parámetro accediendo para ello a la tabla cfgParam. En estas funciones encontramos un segundo argumento opcional bUser del que quiero explicar su utilidad. En una aplicación utilizada por más de un usuari@ los valores a mantener para la próxima ocasión es probable que sea interesante que cada usuari@guarde los suyos y es para esto que si llamamos a una de estas funciones con el valor bUser=True, la función añadirá a NP un sufijo de ‘_USERNAME’ de forma habrá valores diferenciados para cada usuario.
La magia reside en los procedimientos GrabarParam(frm, sPrefijo) y CargarParam(frm, sPrefijo) que recorren todos los controles del formulario y revisan la propiedad Tag, si el tag contiene la cadena “param” se trata de un parámetro si además contiene la cadena paramUS se trata de un parámetro de usuario. Los 3 dígitos de siguen a param o a paramUS indican el tipo de dato: 001 para boolean, 004 para long, 005 currency, 008 date, 010 texto y 012 memo, si no se indican el valor por defecto es 010=Texto.
En resumidas cuentas sólo tenemos que etiquetar (en la propiedad tag) los controles que queremos recordar y llamar a CargarParam (Me, Me.Name & ““) en el Form_Load y a GrabarParam(Me, Me.Name & ““) en el Form_Unload. Lo del prefijo Me.Name & “_” sirve para agrupar todos los parámetros de un formulario precediéndolos del nombre del formulario.
Puedes revisar la tabla cfgParam para observar como se guardan los parámetros
Codigo
'Código de Lorenzo Eizmendi Apellaniz
'Eres libre de usar este código pero nombrando la autoría del mismo.
Option Compare Database
Option Explicit
Dim grsC As Recordset
Dim grsU As Recordset
Public Sub CargarParam(frm As Form, Optional strPrefijo As String = "")
Dim ctl As Control, v As Variant, strParam As String, strParamUS As String
Dim sUserName As String, bUserParam As Boolean
sUserName = GetUserName
Set grsC = CurrentDb.OpenRecordset("cfgParam", dbOpenSnapshot)
Set grsU = CurrentDb.OpenRecordset("cfgParam", dbOpenSnapshot)
On Error GoTo Error_CargarParam
For Each ctl In frm.Controls
If InStr(ctl.Tag, "param") = 0 Then GoTo SiguienteControl
strParam = strPrefijo & ctl.Name
If InStr(ctl.Tag, "paramUS") = 0 Then
strParamUS = ""
If DameVP(strParam, v, False) = True Then
If InStr(ctl.Tag, "paramRowSource") = 0 Then
ctl.Value = v
Else: ctl.RowSource = Nz(v)
End If
End If
Else
strParamUS = strParam & "_" & sUserName
If DameVP(strParamUS, v, True) = True Then
If InStr(ctl.Tag, "paramRowSource") = 0 Then
ctl.Value = v
Else
ctl.RowSource = v
End If
ElseIf DameVP(strParam, v, False) = True Then
If InStr(ctl.Tag, "paramRowSource") = 0 Then
ctl.Value = v
Else
ctl.RowSource = v
End If
End If
End If
SiguienteControl:
Next ctl
Salir_CargarParam:
Set grsC = Nothing
'Set grsP = Nothing
Exit Sub
Error_CargarParam:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en CargarParam" & vbCrLf & Err.Description
Resume Salir_CargarParam
Resume Next
End Select
End Sub
Public Sub GrabarParam(frm As Form, Optional strPrefijo As String = "")
On Error GoTo Error_GrabarParam
Dim ctl As Control, strParam As String, strParamUS As String, vVP, intTipoDato As Integer, strTipoDato As String
Dim sUserName As String, bUserParam As Boolean, bRowSourceParam As Boolean
sUserName = GetUserName
Set grsC = CurrentDb.OpenRecordset("cfgParam", dbOpenDynaset)
Set grsU = CurrentDb.OpenRecordset("cfgParam", dbOpenDynaset)
For Each ctl In frm.Controls
If InStr(ctl.Tag, "param") = 0 Then GoTo SiguienteControl
strParam = strPrefijo & ctl.Name
bUserParam = InStr(ctl.Tag, "paramUS") > 0
bRowSourceParam = InStr(ctl.Tag, "paramRowSource") > 0
If Not bRowSourceParam Then
vVP = ctl.Value
Else
vVP = ctl.RowSource
End If
If Not bUserParam Then
strTipoDato = mId(ctl.Tag, 6, 3)
Else
strTipoDato = mId(ctl.Tag, 8, 3)
strParam = strParam & "_" & sUserName
End If
If Not IsNumeric(strTipoDato) Then strTipoDato = IIf(Not bRowSourceParam, "010", "012")
intTipoDato = CInt(strTipoDato)
If Not PonVP(strParam, vVP, intTipoDato, bUserParam) Then
MsgBox "No se pudo grabar el Parámetro " & strParam
End If
SiguienteControl:
Next ctl
Salir_GrabarParam:
Set grsC = Nothing
Set grsU = Nothing
Exit Sub
Error_GrabarParam:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en GrabarParam" & vbCrLf & Err.Description
Resume Salir_GrabarParam
End Select
End Sub
Public Sub ComprobarParam(frm As Form, Cancel As Integer, Optional intPreguntar As Integer = True, Optional strPrefijo As String = "")
On Error GoTo Error_ComprobarParam
Dim ctl As Control, intResp As Integer, v As Variant, vNew As Variant
Dim i As Integer, intTipoDato As Integer, strParam As String, iParamLen As Integer
Dim sUserName As String, bUserParam As Boolean, bRowSourceParam As Boolean
sUserName = GetUserName
Set grsC = CurrentDb.OpenRecordset("cfgParam", dbOpenDynaset)
Set grsU = CurrentDb.OpenRecordset("cfgParam", dbOpenDynaset)
For Each ctl In frm.Controls
If InStr(ctl.Tag, "param") = 0 Then GoTo SiguienteControl
bUserParam = InStr(ctl.Tag, "paramUS") > 0
bRowSourceParam = InStr(ctl.Tag, "paramRowSource") > 0
If Not bUserParam Then
strParam = strPrefijo & ctl.Name
iParamLen = 5
Else
strParam = strPrefijo & ctl.Name & "_" & sUserName
iParamLen = 7
End If
If DameVP(strParam, v, bUserParam) = True Then
If Not bRowSourceParam Then
vNew = ctl.Value
Else: vNew = ctl.RowSource
End If
If vNew = v Or (IsNull(vNew) And IsNull(v)) Then
Else
If intPreguntar Then
intResp = MsgBox("¿Grabar cambios?", vbDefaultButton1 + vbYesNoCancel + vbQuestion)
Else
intResp = vbYes
End If
Select Case intResp
Case vbYes
GrabarParam frm, strPrefijo
Case vbNo
Case vbCancel
Cancel = True
End Select
GoTo Salir_ComprobarParam
End If
Else
i = InStr(ctl.Tag, "param")
If Len(ctl.Tag) < i + iParamLen + 2 Then
intTipoDato = 10
Else
If IsNumeric(mId(ctl.Tag, i + iParamLen, 3)) Then
intTipoDato = CInt(mId(ctl.Tag, i + iParamLen, 3))
ElseIf Not bRowSourceParam Then
intTipoDato = 10
Else
intTipoDato = 12
End If
End If
'PonValorParam strParam, ctl.value, intTipoDato
PonVP strParam, ctl.Value, intTipoDato, bUserParam
End If
SiguienteControl:
Next ctl
Salir_ComprobarParam:
Set grsC = Nothing
Set grsU = Nothing
Exit Sub
Error_ComprobarParam:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en ComprobarParam" & vbCrLf & Err.Description
Resume Salir_ComprobarParam
End Select
End Sub
Private Function DameVP(strNP As String, vVP As Variant, bUserParam As Boolean) As Integer
'Pone en vVP el valor del parámetro encontrado, si el parámetro no existe Devuelve False, si si true
On Error GoTo Error_DameVP
Dim rs As Recordset
If bUserParam Then
Set rs = grsU
Else
Set rs = grsC
End If
rs.FindFirst "NP = '" & strNP & "'"
If rs.NoMatch Then
DameVP = False
Exit Function
End If
Select Case rs("TipoDato")
Case 10 'text
vVP = rs("VP")
Case 1 'boolean
vVP = rs("VPbool")
Case 2 'byte
vVP = rs("VPlng")
Case 3 'integer
vVP = rs("VPlng")
Case 4 'long
vVP = rs("VPlng")
Case 5 'currency
vVP = rs("VPcur")
Case 6 'single
vVP = rs("VPcur")
Case 7 'double
vVP = rs("VPcur")
Case 8 'date
vVP = rs("VPfecha")
Case 12 'memo
vVP = rs("VPmemo")
Case Else 'text
vVP = rs("VP")
End Select
DameVP = True
Salir_DameVP:
Exit Function
Error_DameVP:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en DameVP" & vbCrLf & Err.Description
Resume Salir_DameVP
Resume Next
End Select
End Function
Public Function GetParam(strNP As String, Optional bUser As Boolean = True _
, Optional bCloseRecordSet As Boolean = True)
On Error GoTo Error_GetParam
Dim strParam As String, vVP
strParam = strNP & IIf(bUser, "_" & GetUserName(), "")
If Not bUser Then
If grsC Is Nothing Then Set grsC = CurrentDb.OpenRecordset("cfgParam", dbOpenSnapshot)
Else
If grsU Is Nothing Then Set grsU = CurrentDb.OpenRecordset("cfgParam", dbOpenSnapshot)
End If
If DameVP(strParam, vVP, bUser) Then
GetParam = vVP
End If
If bCloseRecordSet Then
Set grsC = Nothing
Set grsU = Nothing
End If
Salir_GetParam:
Exit Function
Error_GetParam:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en GetParam" & vbCrLf & Err.Description
Resume Salir_GetParam
Resume Next
End Select
End Function
Public Function SetParam(strNP As String, vVP As Variant, Optional intTipoDato As Integer = 10, Optional intUser As Integer = True _
, Optional bCloseRecordSet As Boolean = True) As Integer
On Error GoTo Error_GetParam
Dim strParam As String
strParam = strNP & IIf(intUser, "_" & GetUserName(), "")
If Not intUser Then
If grsC Is Nothing Then Set grsC = CurrentDb.OpenRecordset("cfgParam", dbOpenDynaset)
Else
If grsU Is Nothing Then Set grsU = CurrentDb.OpenRecordset("cfgParam", dbOpenDynaset)
End If
SetParam = PonVP(strParam, vVP, intTipoDato, CBool(intUser))
If bCloseRecordSet Then
Set grsC = Nothing
Set grsU = Nothing
End If
Salir_GetParam:
Exit Function
Error_GetParam:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en GetParam" & vbCrLf & Err.Description
Resume Salir_GetParam
Resume Next
End Select
End Function
Private Function PonVP(strNP As String, vVP As Variant, Optional intTipoDato As Integer = 10, Optional bUserParam As Boolean = True) As Integer
'Graba el valor vVP en el parámetro strNP, si el parámetro no existe lo crea con el tipo indicado
On Error GoTo Error_PonVP
Dim rs As Recordset
If bUserParam Then
Set rs = grsU
Else
Set rs = grsC
End If
rs.FindFirst "NP = '" & strNP & "'"
If rs.NoMatch Then
rs.AddNew
rs("NP") = strNP
rs("TipoDato") = intTipoDato
Else
rs.Edit
End If
Select Case rs("TipoDato")
Case 10 'text
rs("VP") = vVP
Case 1 'boolean
rs("VPbool") = vVP
Case 2 'byte
rs("VPlng") = vVP
Case 3 'integer
rs("VPlng") = vVP
Case 4 'long
rs("VPlng") = vVP
Case 5 'currency
rs("VPcur") = vVP
Case 6 'single
rs("VPcur") = vVP
Case 7 'double
rs("VPcur") = vVP
Case 8 'date
rs("VPfecha") = vVP
Case 12 'memo
rs("VPmemo") = IIf(vVP = "", Null, vVP)
Case Else 'text
rs("VP") = vVP
End Select
rs("FModificado") = Now()
rs.Update
PonVP = True
Salir_PonVP:
Exit Function
Error_PonVP:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en PonVP" & vbCrLf & Err.Description
Resume Salir_PonVP
Resume Next
End Select
End Function
Public Function PonValorParamAC(Optional intTipoDato As Integer = 10, Optional intForzarTipoDato As Integer = False) As Integer
'Graba el valor vVP en el parámetro strNP, si el parámetro no existe lo crea con el tipo indicado
'Pasa El nombre y Calor del Control Activo a PonValorParam
On Error GoTo Error_PonValorParamAC
Dim strNP As String, vVP As Variant
Dim ctl As Control, i As Integer, v As Variant
Dim intUser As Integer
Set ctl = Screen.ActiveControl
strNP = ctl.Name
vVP = ctl.Value
i = InStr(ctl.Tag, "param")
If i > 0 Then
intUser = InStr(ctl.Tag, "paramUS") > 0
If Len(ctl.Tag) >= i + 7 Then
v = mId(ctl.Tag, i + 5, 3)
On Error Resume Next
intTipoDato = CInt(v)
On Error GoTo Error_PonValorParamAC
End If
End If
'PonValorParam strNP, vVP, intTipoDato, , intForzarTipoDato
SetParam strNP, vVP, intTipoDato, intUser
PonValorParamAC = True
Salir_PonValorParamAC:
Exit Function
Error_PonValorParamAC:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en PonValorParamAC" & vbCrLf & Err.Description
Resume Salir_PonValorParamAC
Resume Next
End Select
End Function
Public Function PonValorParamRemoto(strMDB As String, strNP As String, vVP As Variant, Optional intTipoDato As Integer = 10, Optional intMensaje As Integer = True) As Integer
'Graba el valor vVP en el parámetro strNP, si el parámetro no existe lo crea con el tipo indicado
On Error GoTo Error_PonValorParamRemoto
Dim rs As Recordset
Dim db As dao.Database
Set db = OpenDatabase(strMDB)
If strNP Like "Puesto*" Then
Set rs = db.OpenRecordset("pstParam", dbOpenDynaset, dbSeeChanges)
Else
Set rs = db.OpenRecordset("cfgParam", dbOpenDynaset, dbSeeChanges)
End If
rs.FindFirst "NP = '" & strNP & "'"
If rs.NoMatch Then
If intMensaje Then MsgBox "Se va a añadir Parámetro " & strNP & " en base: " & strMDB
rs.AddNew
rs("NP") = strNP
rs("TipoDato") = intTipoDato
Else
rs.Edit
End If
Select Case rs("TipoDato")
Case 10 'text
rs("VP") = vVP
Case 1 'boolean
rs("VPbool") = vVP
Case 2 'byte
rs("VPlng") = vVP
Case 3 'integer
rs("VPlng") = vVP
Case 4 'long
rs("VPlng") = vVP
Case 5 'currency
rs("VPcur") = vVP
Case 6 'single
rs("VPcur") = vVP
Case 7 'double
rs("VPcur") = vVP
Case 8 'date
rs("VPfecha") = vVP
Case 12 'memo
rs("VPmemo") = vVP
Case Else 'text
rs("VP") = vVP
End Select
rs.Update
PonValorParamRemoto = True
Salir_PonValorParamRemoto:
Exit Function
Error_PonValorParamRemoto:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en PonValorParamRemoto" & vbCrLf & Err.Description
Resume Salir_PonValorParamRemoto
Resume Next
End Select
End Function
Public Function DameValorParamRemoto(strMDB As String, strNP As String, Optional strTable As String = "cfgParam", Optional ByRef intOK As Integer = False) As Variant
'Devuelve el valor del parámetro encontrado, si el parámetro no existe Devuelve ""
On Error GoTo Error_DameValorParamRemoto
Dim rs As Recordset, vVP As Variant, db As dao.Database
Set db = OpenDatabase(strMDB, , True)
Set rs = db.OpenRecordset(strTable, dbOpenSnapshot)
rs.FindFirst "NP = '" & strNP & "'"
If rs.NoMatch Then
DameValorParamRemoto = Null
Exit Function
End If
Select Case rs("TipoDato")
Case 10 'text
vVP = rs("VP")
Case 1 'boolean
vVP = rs("VPbool")
Case 2 'byte
vVP = rs("VPlng")
Case 3 'integer
vVP = rs("VPlng")
Case 4 'long
vVP = rs("VPlng")
Case 5 'currency
vVP = rs("VPcur")
Case 6 'single
vVP = rs("VPcur")
Case 7 'double
vVP = rs("VPcur")
Case 8 'date
vVP = rs("VPfecha")
Case 12 'memo
vVP = rs("VPmemo")
Case Else 'text
vVP = rs("VP")
End Select
DameValorParamRemoto = vVP
intOK = True
Salir_DameValorParamRemoto:
Exit Function
Error_DameValorParamRemoto:
Select Case Err
Case Else
MsgBox "error nº " & Err & " en DameValorParamRemoto" & vbCrLf & Err.Description
intOK = False
Resume Salir_DameValorParamRemoto
Resume Next
End Select
End Function
Public Function DirectorioDe(strFullPath As String _
, Optional bConBarraFinal As Boolean = True) As String
Dim i As Integer
On Error GoTo HandleError
i = InStrRev(strFullPath, "\")
If i > 0 Then
DirectorioDe = Left(strFullPath, IIf(bConBarraFinal, i, i - 1))
End If
HandleExit:
Exit Function
HandleError:
Select Case Err
Case Else
MsgBox "Error nº: " & Err & " en DirectorioDe" & vbCrLf & Err.Description
End Select
Resume HandleExit
End Function
Public Function GetUserName() As String
GetUserName = Environ("USERNAME")
End Function
Public Function GetComputerName() As String
GetComputerName = Environ("COMPUTERNAME")
End Function
Archivo de ejemplo
Pregunta Sé cómo imprimir un informe mediante código y sé cómo hacer para que aparezca el cuadro de diálogo imprimir,…
Cómo conseguir en un informe calcular sólo el total para cada página