'Módulo estándar: "ModAggDomRem"
Option Compare Database
Option Explicit
Public Db As Object
Public rst As Object
Public MiSQL As String
Public Valor As Variant
Public Function rCount(ByVal rCampo As String, ByVal rTabla As String, Optional rDonde As String = "", Optional dbPath As String, Optional UseJetLink As Boolean = True) As Long
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rCount
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función que devuelve la cuenta de registros de una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor long con el número de registros
'--------------------------------------------------------------------------------------------------
rCount = 0
On Error GoTo lbError
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT COUNT(" & rCampo & ") as MiValor FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde & "") <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = 0
Else
rst.MoveFirst
Valor = rst!MiValor
End If
rCount = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rCount del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
Function rLookUp(ByVal rCampo As String, ByVal rTabla As String, Optional rDonde As String = "", Optional dbPath As String, Optional UseJetLink As Boolean = True) As Variant
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rLookUp
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función para buscar un dato en una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor variant con el dato buscado
'--------------------------------------------------------------------------------------------------
On Error GoTo lbError
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT " & rCampo & " FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde) & "" <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = Null
Else
rst.MoveFirst
Valor = rst.Fields(rCampo).Value
End If
rLookUp = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rLookUp del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
Public Function rMax(ByVal rCampo As String, ByVal rTabla As String, Optional rDonde As String = "", Optional dbPath As String, Optional UseJetLink As Boolean = True) As Variant
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rMax
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función para buscar el máximo de un conjunto de registros de una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor variant con el dato buscado
'--------------------------------------------------------------------------------------------------
rMax = Null
On Error GoTo lbError
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT MAX(" & rCampo & ") as MiValor FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde & "") <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = Null
Else
rst.MoveFirst
Valor = rst!MiValor
End If
rMax = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rMax del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
Public Function rMin(ByVal rCampo As String, ByVal rTabla As String, Optional rDonde As String = "", Optional dbPath As String, Optional UseJetLink As Boolean = True) As Variant
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rMin
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función para buscar el mínimo de un conjunto de registros de una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor variant con el dato buscado
'--------------------------------------------------------------------------------------------------
rMin = Null
On Error GoTo lbError
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT MIN(" & rCampo & ") as MiValor FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde & "") <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = Null
Else
rst.MoveFirst
Valor = rst!MiValor
End If
rMin = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rMin del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
Public Function rSum(ByVal rCampo As String, ByVal rTabla As String, Optional rDonde As String, Optional dbPath As String, Optional UseJetLink As Boolean = True) As Variant
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rSum
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función para sumar un conjunto de registros de una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor variant con el dato buscado
'--------------------------------------------------------------------------------------------------
rSum = Null
On Error GoTo lbError
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT SUM(" & rCampo & ") as MiValor FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde) & "" <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = Null
Else
rst.MoveFirst
Valor = Nz(rst!MiValor, 0)
End If
rSum = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rSum del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
Function rAvg(rCampo As String, rTabla As String, Optional rDonde As String, Optional dbPath As String, Optional UseJetLink As Boolean = True) As Variant
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rAvg
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función para obtener la media un conjunto de registros de una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor variant con el dato buscado
'--------------------------------------------------------------------------------------------------
On Error GoTo lbError
rAvg = Null
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT AVG(" & rCampo & ") as Media FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde) & "" <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = Null
Else
rst.MoveFirst
Valor = Nz(rst!MiValor, 0)
End If
rAvg = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rAvg del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
Function rFirst(rCampo As String, rTabla As String, Optional rDonde As String, Optional dbPath As String, Optional UseJetLink As Boolean = True) As Variant
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rFirst
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función para obtener el primer registro de un conjunto de registros de una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor variant con el dato buscado
'--------------------------------------------------------------------------------------------------
On Error GoTo lbError
rFirst = Null
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT FIRST(" & rCampo & ") as MiFirst FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde & "") <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = Null
Else
rst.MoveFirst
Valor = Nz(rst!MiValor, 0)
End If
rFirst = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rFirst del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
Function rLast(rCampo As String, rTabla As String, Optional rDonde As String, Optional dbPath As String, Optional UseJetLink As Boolean = True) As Variant
'--------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-funciones-de-dominio-de-alba-funciones-remotas
'--------------------------------------------------------------------------------------------------
' Título : rLast
' Autor original : Alba Salvá
' Creado : 12/03/2023
' Propósito : función para obtener el último registro de un conjunto de registros de una BD remota
' Argumentos : La sintaxis de la función consta de los siguientes argumentos
' Variable Modo Descripción
'--------------------------------------------------------------------------------------------------
' rCampo Obligatorio Nombre del campo
' rTabla Obligatorio Nombre de la tabla
' rDonde Opcional Criterios adicionales para la búsqueda
' dbPath Opcional Para buscar en bases de datos externas
' UseJetLink Opcional Para buscar usando JetLink (solo BBDD Access)
'--------------------------------------------------------------------------------------------------
' Retorno : valor variant con el dato buscado
'--------------------------------------------------------------------------------------------------
On Error GoTo lbError
rLast = Null
If dbPath = "" Or (dbPath <> "" And UseJetLink) Then
Set Db = CurrentDb
Else
Set Db = DBEngine.OpenDatabase(dbPath)
End If
If Not wzBracketString(rCampo, 1) Then GoTo lbErrorBracketString
If Not wzBracketString(rTabla, 1) Then GoTo lbErrorBracketString
MiSQL = "SELECT LAST(" & wzBracketString(rCampo, 1) & ") as MiLast FROM "
If UseJetLink And dbPath <> "" Then
MiSQL = MiSQL & "[" & dbPath & "]."
End If
MiSQL = MiSQL & rTabla
If Trim(rDonde & "") <> "" Then
MiSQL = MiSQL & " WHERE " & rDonde
End If
Set rst = Db.OpenRecordset(MiSQL, dbOpenSnapshot, dbReadOnly)
If rst.BOF And rst.EOF Then
Valor = Null
Else
rst.MoveFirst
Valor = rst!MiLast
End If
rLast = Valor
GoTo lbFinally
lbErrorBracketString:
MsgBox "Error en conversión BracketString en Function rCount del Módulo ModAggDomRem"
GoTo lbFinally
lbError:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en Function rLast del Módulo ModAggDomRem"
lbFinally:
On Error Resume Next
If Not rst Is Nothing Then rst.Close
Set rst = Nothing
If Not Db Is Nothing Then Db.Close
Set Db = Nothing
On Error GoTo 0
End Function
2 Comments
Hola:
He copiado y probado el código de las Funciones de Domínio de Alba Salvá.
Un excelente trabajo de Alba y del resto de colaboradores, que contribuye en gran manera al aprendizaje de otras personas.
He encontrado algunas líneas que en mi caso producen errores.
En todas las Funciones: >> Tengo la Función >>Public Function wzBracketString(StrCadenaIn As String, Flag As Long) As String
If Not wzBracketString(RCampo, 1) Then GoTo LbErrorBracketString
If Not wzBracketString(RTabla, 1) Then GoTo LbErrorBracketString
Me da error de “No coinciden los tipos”
En las Funciones:
RAvg(…. >> ‘Valor = Nz(Rst!MiValor, 0) debe ser >>Valor = Nz(Rst!Media, 0)
RFirst(…..>>’Valor = Nz(Rst!MiValor, 0) debe ser >>Valor = Nz(Rst!MiFirst, 0)
Son errores de ir escribiendo y pasar por alto el valor declarado en cada sítio.
Un cordial saludo >> Jacinto
Muchísimas gracias Jacinto. Te agradecemos mucho tu comentario.
Alba tendrá en cuenta tu comentario.
Gracias de nuevo.