Reiniciar campo autonumérico

El campo autonumérico de una tabla se reinicia cuando ésta está vacía y se compacta la base de datos. De todas formas mediante el siguiente código, y sin necesidad de compactar la base de datos, se reinicia el campo autonumérico de la tabla.

Function ChangeSeed(strTbl As String, strCol As String, lngSeed As Long) As Boolean
'Se deben pasar las siguientes variables a la función:
'strTbl = Tabla que contiene el autonumérico a reiniciar
'strCol = Nombre del campo autonumérico
'lngSeed = Valor del campo autonumérico que se quiere dar al próximo registro de la tabla
Dim cnn As ADODB.Connection
Dim cat As New ADOX.Catalog
Dim col As ADOX.Column
'Establece la conexión con la base de datos
Set cnn = CurrentProject.Connection
cat.ActiveConnection = cnn
Set col = cat.Tables(strTbl).Columns(strCol)
col.Properties("Seed") = lngSeed
cat.Tables(strTbl).Columns.Refresh
If col.Properties("seed") = lngSeed Then
ChangeSeed = True
Else
ChangeSeed = False
End If
Set col = Nothing
Set cat = Nothing
Set cnn = Nothing
End Function

Fuente: Alexandre Minato

Interactuación con el ratón

El siguiente ejemplo muestra como interactuar el objetos existentes en un formulario con el movimiento del ratón. Además permite utilizar o no una determinada función para realizar una operación según convenga.

Descargar: Access 97

Fuente: Utter Access

Localizar un archivo

El siguiente código muestra cómo obtener la/s ubicacion/es de un archivo en una ruta determinada, utilizando el objeto de FileSearch incluido en el objeto Application.

Function LocateFile(strFileName as String)
   Dim vItem As Variant
   With Application.FileSearch
      .FileName = strFileName
      .LookIn = "C:\"
      .SearchSubFolders = True
      .Execute
      For Each vItem In .FoundFiles
         Debug.Print vItem
      Next vItem
   End With
End Function

Fuente: Microsoft

Combos en un formulario continuo

El siguiente ejemplo muestra como solucionar el problema que se da al introducir un combo box en un formulario continuo. El valor de dicho control únicamente se muestra cuando se está sobre un determinado registro, mostrásndose en blanco en el resto. Para resolver el problema se utiliza un textbox auxiliar, que se utiliza de forma complementaria para mostrar el valor.

Descargar: Access 2000

Fuente: KDSnell

Seleccionar valor en un combo-box

El siguiente ejemplo muestra cómo seleccionar un valor entre varios que comiencen de igual forma. Al iniciar el formulario se muestra un cuadro de texto, el cual al introducir tres caracteres se ‘convierte’ en un combo-box en el que se muestran todos los registros que cumplen con la condición de empezar por la cadena indicada. Para así poder seleccionar el deseado.

Descargar: Access 2000

Fuente: KDSness

Leer el archivo *.ldb

La siguiente función lee el archivo .ldb asociado a una base de datos de Access, y devulelve un listado con los usuarios que están conectados a la base de datos. El archivo .ldb se utiliza para determinar qué registros se bloquean en una base de datos compartida y quién los bloquea.

Public Function WhoIsInTheDatabaseLockFile() As String
Dim cn As New ADODB.Connection
Dim dbs As DAO.Database
Dim xlngLoop As Long
Dim rs As New ADODB.Recordset
Dim strNewDataSource As String, strCNString As String, xTT As String
Dim strCurrConnectString As String, xstrUserArray As String

Const strDummyTableName As String = "tbl__DummyTable_KeepRecordsetOpen"
Const strDatabaseString As String = "DATABASE="
Const strDataSourceText As String = "Data Source="

On Error GoTo Err_Msg

xstrUserArray = ""
strCurrConnectString = CurrentProject.Connection
strCNString = Mid(strCurrConnectString, InStr(strCurrConnectString, _
      strDataSourceText) + Len(strDataSourceText))
strCNString = Left(strCNString, InStr(strCNString, ";") - 1)

Set dbs = CurrentDb
strNewDataSource = dbs.TableDefs(strDummyTableName).Connect
strNewDataSource = Mid(strNewDataSource, InStr(strNewDataSource, _
      strDatabaseString) + Len(strDatabaseString))
Debug.Print "File containing the data tables: " & strNewDataSource

cn.ConnectionString = Replace(strCurrConnectString, strCNString, _
strNewDataSource, 1, 1, vbTextCompare)
cn.Open

Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")

Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
      "", rs.Fields(2).Name, rs.Fields(3).Name

While Not rs.EOF
      Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)

      For xlngLoop = 0 To 3
            xTT = Trim(Nz(rs.Fields(xlngLoop), ""))
            If Len(xTT) > 1 Then
                  If Right(xTT, 1) = Chr(0) Then xTT = Left(xTT, Len(xTT) - 1)
            End If
            xstrUserArray = xstrUserArray & xTT & strPipeDelimiterChar
      Next xlngLoop

      rs.MoveNext
Wend

If Len(xstrUserArray) > 0 Then xstrUserArray = Left(xstrUserArray, _
      Len(xstrUserArray) - 1)
WhoIsInTheDatabaseLockFile = xstrUserArray

Exit_Function:
      On Error Resume Next
      rs.Close
      Set rs = Nothing
      cn.Close
      Set cn = Nothing
      dbs.Close
      Set dbs = Nothing
      Exit Function

Err_Msg:
      Debug.Print "Error occurred. Error number " & Err.Number & ": " & Err.Description
      Resume Exit_Function

End Function

Fuente: KDSnell

Buscar una cadena en todas las tablas del usuario

El siguiente ejemplo muestra como buscar un valor en todas las tablas, que no son del sistema, y en todos los campos de cada una de las tablas.

Descargar. Access 2000.

Fuente: Candace Tripp

Árbol sin usar el control Treeview

El siguiente ejemplo muestra como realizar un árbol, en el que se expandan y contraigan los distintos elementos que lo componen sin utilizar el control de Access Treeview.

Descargar: Access 2000

Fuente: David Plaut

Tabular en un cuadro de texto

El siguiente ejemplo muestra como, de una forma sencilla, realizar tabulaciones en un cuadro de texto. Para ello es utiliza una función que hace que la tecla TAB, sobre un determinado control, actúe de una forma particular.

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim CursorPosition As Integer
Dim NumberOfCrLfsInSelected As Integer
Dim FirstHalf As String
Dim SecondHalf As String
If KeyCode = vbKeyTab And Me.ActiveControl.Name = "MyTextField" Then
Me.Painting = False
CursorPosition = Me.MyTextField.SelStart
FirstHalf = Left(Me.MyTextField.Text, CursorPosition)
SecondHalf = Mid(Me.MyTextField.Text, CursorPosition + 1)
Me.MyTextField = FirstHalf & "    " & SecondHalf
Me.MyTextField.SelStart = CursorPosition + 4
KeyCode = 0
Me.Painting = True
End If
End Sub

Fuente: Walter Niesz

Cálculo de la fecha de Semana Santa

La llamada a la función que calcula la fecha del Domingo de Resurrección se realiza de la siguiente forma:

Private Sub XecSS()
Dim intAnio As Integer
intAnio = InputBox("¿ Qué año ?")
MsgBox "Domingo de resureccion es:  " & funSemanaSanta(intAnio), vbInformation
End Sub

El año debe estar comprendido entre 1583 (inicio del calendario Gregoriano) y 2299. La función que nos devuelve la fecha buscada es la siguiente:

Public Function funSemanaSanta(ByVal Pon_Anio As Integer) As String
Dim bytA As Byte
Dim bytB As Byte
Dim bytC As Byte
Dim bytD As Byte
Dim bytN As Byte
Dim bytM As Byte
Dim bytX As Byte
Dim bytY As Byte
If Pon_Anio >= 1583 And Pon_Anio < = 1699 Then
bytX = 22
bytY = 2
ElseIf Pon_Anio >= 1700 And Pon_Anio < = 1799 Then
bytX = 23
bytY = 3
ElseIf Pon_Anio >= 1800 And Pon_Anio < = 1899 Then
bytX = 23
bytY = 4
ElseIf Pon_Anio >= 1900 And Pon_Anio < = 2099 Then
bytX = 24
bytY = 5
ElseIf Pon_Anio >= 2100 And Pon_Anio < = 2199 Then
bytX = 24
bytY = 6
ElseIf Pon_Anio >= 2200 And Pon_Anio < = 2299 Then
bytX = 25
bytY = 0
Else
MsgBox "Error", vbCritical
Exit Function
End If
bytA = Pon_Anio Mod 19
bytB = Pon_Anio Mod 4
bytC = Pon_Anio Mod 7
bytD = ((19 * bytA) + bytX) Mod 30
bytN = ((2 * bytB) + (4 * bytC) + (6 * bytD) + bytY) Mod 7
bytM = bytD + bytN
If bytM < 10 Then
Rem marzo
funSemanaSanta = bytM + 22 & " Marzo"
Else
Rem abril
If bytM - 9 = 26 Then
funSemanaSanta = "19 Abril"
ElseIf bytD = 28 And bytN = 6 And bytA > 10 Then
funSemanaSanta = "18 Abril"
Else
funSemanaSanta = bytD + bytN - 9 & " Abril"
End If
End If
End Function

Fuente: javier.mil