Reiniciar campo autonumérico
2.07.2009
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
27.06.2009
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
23.06.2009
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
22.06.2009
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
22.06.2009
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
17.06.2009
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
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
12.05.2009
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
19.04.2009
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
19.04.2009
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





