Funciones de Autonumericos en VBA para ACCESS

Funcin que calcula el valor mximo de una tabla y un campo pasados como
parmetros
parmetros, teniendo en cuenta el prefijo del campo
Funcin que calcula el valor mximo de una tabla de detalle segn el valor de la tabla
principal
parmetros, teniendo en cuenta el Sufijo del campo
Funcin que busca el primer nmero de orden libre en la tabla y campo pasados
como parmetros
Funcin que busca el prximo nmero a partir de una tabla de registro de ltimo
nmero usado, especialmente til cuando los usuarios son muchos
Funcin que genera aleatoriamente y dentro de un rango un valor, verificando que
no exista en el campo de la tabla indicados
'************************************************************************
***********
'* Funcin que calcula el valor mximo de una tabla y un campo pasados
como parmetros
'* uso: AutoNumerico("Pendientes","id")
'* ESH 09/09/00 15:50
'************************************************************************
***********
Public Function AutoNumerico(strTabla As String, strCampo As String) As
Integer
Dim dbs As Database, _
rst As Recordset, _
strMaximo As String
' creo una cadena con la select para obtener el valor ms alto del campo
strMaximo = "SELECT Max(" & strCampo & ") as Mayor FROM
" & strTabla
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strMaximo)
' abro un recordset con esa
cadena
If IsNull(rst!Mayor) Then
AutoNumerico = 1
' si la tabla est vaca
Else
AutoNumerico = rst!Mayor + 1
' devuelvo el valor incrementado
en uno
End If
' cierro el recordset
rst.Close
Set rst = Nothing
Set dbs = Nothing
End Function
' AutoNumerico
Volver arriba
'************************************************************************
***********
como parmetros,
'* teniendo en cuenta el prefijo del campo, que ir separado por una
"/".
'* el campo deber ser de texto
'* uso: AutoNumerico2("Pendientes","id")
'* Para tablas nuevas o cambio de prefijo, se puede pasar un prefijo

opcional
(sin "/")
'* en cuyo caso comienza a contar desde 1
'* uso: AutoNumerico2("Pendientes","id", "2002")
'* ESH 18/04/01 19:15
'************************************************************************
***********
Public Function AutoNumerico2(strTabla As String, strCampo As String,
Optional
strPrefijo As String) As String
rst As Recordset,
_
strMaximo As String
Set dbs = CurrentDb
If strPrefijo = "" Then
Set rst = dbs.OpenRecordset(strTabla,
dbOpenDynaset)
If Not rst.EOF()
And Not rst.BOF() Then
rst.MoveLast
strPrefijo = Left(rst(strCampo), InStr(rst(strCampo),
"/"))
rst.Close
End If
' Not rst.EOF() And Not rst.BOF()
Else
strPrefijo = strPrefijo
& "/"
AutoNumerico2 =
strPrefijo & 1
Exit Function
End If ' IsEmpty(strPrefijo)
strMaximo = "SELECT Max(Val(Mid(" & strCampo & ",InStr(" & strCampo &
",'/')+1))) as Mayor FROM " & strTabla
' abro un
recordset con esa cadena
' si es nulo lo
hago 1
AutoNumerico2 =
strPrefijo & 1
Else
AutoNumerico2 =
strPrefijo & rst!Mayor + 1
' devuelvo el
valor incrementado en uno
End If
' IsNull(rst!Mayor)
rst.Close
Set rst = Nothing
Set dbs = Nothing
End Function
' AutoNumerico2
Volver arriba
'************************************************************************
***********
'* Funcin que calcula el valor mximo de una tabla (LineasFactura) y un
campo (Linea),
'* para un campo clave (NumFactura) que cumple una condicin (01-2001)
'* es el caso tpico de numeracin de lneas de factura
o boletn.
'* uso: txtNumero = AutoNumerico3("LineasFactura", "Linea", "NumFactura",
"01-2001")
'* ESH 01/05/01 10:32
'************************************************************************
***********
strClave As String, strValorClave As String) As Integer

rst As Recordset, _
strMaximo As String
strMaximo = "SELECT Max(" & strCampo & ") as Mayor FROM " & strTabla
strMaximo = strMaximo & " WHERE " & strClave & " = '" & strValorClave &
"'"
Set dbs = CurrentDb
' abro un recordset con
esa cadena
AutoNumerico3 = 1
'
si la tabla est
vaca
Else
AutoNumerico3 = rst!Mayor + 1
' devuelvo el valor
incrementado en uno
End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
End Function
' AutoNumerico3
Volver arriba
'************************************************************************
***********
como parmetros,
'* teniendo en cuenta el Sufijo del campo, que ir separado por un "-".
'* el campo deber ser de texto
'* uso: AutoNumerico4("Pendientes","id")
'* Para tablas nuevas o cambio de sufijo, se puede pasar un sufijo
opcional (sin "-")
'* en cuyo caso comienza a contar desde 1
'* uso: AutoNumerico4("Pendientes","id", "2002")
'* ESH 09/05/01 18:15
'************************************************************************
***********
Optional strSufijo As String) As String
rst As Recordset, _
strMaximo As String
Set dbs = CurrentDb
If strSufijo = "" Then
Set rst = dbs.OpenRecordset(strTabla, dbOpenDynaset)
If Not rst.EOF() And Not rst.BOF() Then
rst.MoveLast
strSufijo = Right(rst(strCampo), InStr(rst(strCampo), "-"))
rst.Close
End If
' Not rst.EOF() And Not rst.BOF()
Else
AutoNumerico4 = "0001-" & strSufijo
Exit Function
End If
' strSufijo = ""
strMaximo = "SELECT Max(Val(left(numfactura,InStr(numfactura,'-')-1))) as

Mayor FROM " & strTabla
' abro un
recordset con esa cadena
' si es nulo lo
hago 1
AutoNumerico4 = "0001" & strSufijo
Else
AutoNumerico4 =Format(rst!Mayor + 1, "0000") & strSufijo
'
devuelvo el valor incrementado en uno
End If ' IsNull(rst!Mayor)
rst.Close
Set rst = Nothing
Set dbs = Nothing
End Function
' AutoNumerico4
Volver arriba
'************************************************************************
***********
'* funcin que busca el primer nmero de orden libre en la tabla
y
campo pasados como parmetros
'* uso: intCodigo = BuscarLibre("Tabla1","id")
'* ESH 10/04/01 18:35
'************************************************************************
***********
Public Function BuscarLibre(strTabla As String, strCampo As String) As
Long
' declaraciones
Dim dbs As Database
rst As Recordset
strSQL As String
lngAnterior As Long
' crear recordset
strSQL = "SELECT " & strCampo & " FROM " & strTabla & " ORDER BY " &
strCampo & " ASC"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL, dbOpenDynaset)
lngAnterior = 1
' busco el primer hueco libre
With rst
' si la tabla est vaca
If .EOF And .BOF Then
BuscarLibre
= 1
Exit Function
Else
' si el primer registro es distinto de 1
If rst(strCampo) > 1 Then
BuscarLibre = 1
Exit Function
End If
' (IsNull(rst(strCampo)) Or rst(strCampo) > 1)
End If
' Not .EOF And Not .BOF
' si el primer registro esta vaco
If IsNull(rst(strCampo)) Then
MsgBox "Hay al menos un registro NULO, corrigelo antes de

continuar", vbOKOnly + vbCritical, "ATENCION"
Exit Function
End If
' IsNull(rst(strCampo))
Do
Select Case rst(strCampo)
' si el siguiente es correlativo
Case Is = lngAnterior
+ 1
lngAnterior = rst(strCampo)
.MoveNext
' si el siguiente est libre
Case Is > lngAnterior
+ 1
BuscarLibre = lngAnterior + 1
Exit Do
Case Is = lngAnterior
' si es igual (primer caso)
lngAnterior = rst(strCampo)
.MoveNext
End Select
' rst(strCampo)
Loop While Not .EOF
' si hemos llegado al fin de la tabla y estaban todos ocupados
If .EOF Then BuscarLibre = lngAnterior + 1
End With
' rst
' cierro recordsets y base de datos
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
End Function
' BuscarLibre
Volver arriba
'************************************************************************
*******
'* Autonumerico5
'* Calcula el prximo nmero a asignar a un registro, partiendo del
almacenado
'* en una tabla Numeros cuya estructura ser
'*
Campo Tabla
Alfanumrico Indexado sin duplicados
'*
Campo Numero
Entero Largo
'* dicha tabla contendr un registro para cada tabla que cuente con un
'* campo autonumrico controlado
'* Argumentos:
'* uso: Autonumerico5 "Facturas"
'* ESH 31/08/04 18:39
'************************************************************************
*******
Private Function Autonumerico5(strTabla As String) As Long
Dim rst As DAO.Recordset, _
strSQL As String, _
lngNumero As Long
' abro un recordset con el ultimo nmero guardado
On Error GoTo Autonumerico5_TratamientoErrores
strSQL = "SELECT * FROM Numeros WHERE Tabla = '" & strTabla & "'"
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)

' como precaucin, no debera ocurrir, pero por si acaso, me aseguro de
que me devuelve datos
If Not rst.EOF And Not rst.BOF Then
' meto en una variable el ultimo nmero guardado
lngNumero = rst!Numero
End If
' incremento en uno el nmero
lngNumero = lngNumero + 1
' edito el registro
rst.Edit
' cambio el nmero anterior por el nuevo
rst!Numero = lngNumero
' guardo el registro
rst.Update
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
Autonumerico5 = lngNumero
Autonumerico5_Salir:
On Error GoTo 0
Exit Function
Autonumerico5_TratamientoErrores:
MsgBox "Error " & Err.Number & " en proc. Autonumerico5 de Mdulo Mdulo1
(" & Err.Description & ")", vbOKOnly + vbCritical
GoTo Autonumerico5_Salir
End Function ' Autonumerico5
Volver arriba
'************************************************************************
*******
'* AutoNumericoAleatorio
'* genera un nmero aleatorio dentro del rango solicitado verificando que
no
'* exista previamente en el campo y tabla indicadas
'* Argumentos: strTabla
=> Tabla en que se va a insertar el valor
'*
strCampo
=> Campo en el que se va a insertar el valor
'*
lngMinimo => Valor mnimo
'*
lngMaximo => Valor mximo
'* uso: AutoNumericoAleatorio "LaTabla", "ElCampo", 0, 999999

'* ESH 28/01/07 17:53
'************************************************************************
*******
Public Function AutoNumericoAleatorio(strTabla As String, strCampo As
String, lngMinimo As Long, lngMaximo As Long) As Long
Dim lngNuevo As Long, _

rst As DAO.Recordset, _
strSQL As String
On Error GoTo AutoNumericoAleatorio_TratamientoErrores

' abro un recordset con el campo y la tabla indicados
strSQL = "SELECT " & strCampo
strSQL = strSQL & " FROM " & strTabla
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rst.EOF And rst.BOF) Then

Do
' genero aleatoriamente un valor dentro del rango
lngNuevo = Int((lngMaximo - lngMinimo + 1) * Rnd + lngMinimo)
' verifico si existe en la tabla
rst.FindFirst strCampo & " = " & lngNuevo
If rst.NoMatch Then
' si no existe lo devuelvo y salgo del bucle
AutoNumericoAleatorio = lngNuevo
Exit Do
End If ' si ya existe lo intento de nuevo
Loop Until 0 = 1
Else ' si no hay registros genero aleatoriamente un valor dentro del
rango indicado
AutoNumericoAleatorio = Int((lngMaximo - lngMinimo + 1) * Rnd +
lngMinimo)
End If
AutoNumericoAleatorio_Salir:
On Error Resume Next
' cierro el recodset
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
On Error GoTo 0
Exit Function
AutoNumericoAleatorio_TratamientoErrores:
MsgBox "Error " & Err.Number & " en proc.: AutoNumericoAleatorio de
Mdulo: Mdulo1 (" & Err.description & ")", vbCritical + vbOKOnly,
"ATENCION"
Resume AutoNumericoAleatorio_Salir
End Function ' AutoNumericoAleatorio

Funciones de Autonumericos en VBA para ACCESS

Cargado por

Copyright:

Formatos disponibles

Funciones de Autonumericos en VBA para ACCESS

Cargado por

Información del documento

Descripción original:

Título original

Derechos de autor

Formatos disponibles

Compartir este documento

Compartir o incrustar documentos

Opciones para compartir

¿Le pareció útil este documento?

¿Este contenido es inapropiado?

Copyright:

Formatos disponibles

Funciones de Autonumericos en VBA para ACCESS

Cargado por

Copyright:

Formatos disponibles

Funcin que calcula el valor mximo de una tabla y un campo pasados como

'* Para tablas nuevas o cambio de prefijo, se puede pasar un prefijo

Dim dbs As Database, _

strMaximo = "SELECT Max(Val(left(numfactura,InStr(numfactura,'-')-1))) as

MsgBox "Hay al menos un registro NULO, corrigelo antes de

Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)

=> Tabla en que se va a insertar el valor

=> Campo en el que se va a insertar el valor

lngMinimo => Valor mnimo

lngMaximo => Valor mximo

'* uso: AutoNumericoAleatorio "LaTabla", "ElCampo", 0, 999999

Dim lngNuevo As Long, _

On Error GoTo AutoNumericoAleatorio_TratamientoErrores

Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)

If Not (rst.EOF And rst.BOF) Then

End Function ' AutoNumericoAleatorio

También podría gustarte

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.