Cómo manejar fechas en consultas
(además de otras cosillas más...)
Ejemplos con ADO y DAO
 

Publicado: 09/Jul/2003
Actualizado: 10/Jul/2003

 


Lo que vamos a ver aquí es algo bastante simple, será el uso de una fecha en una consulta SQL.

Nota:
Recuerda (o lo aclaro) que una consulta SQL no es una consulta hecha a una base de datos del tipo SQL, sino es una cadena "SELECT" que se usa para obtener los datos de una base de datos, sea del tipo que sea.

El problema con las fechas es que no siempre funciona como nos gustaría, sobre todo si en la consulta se indica más de una fecha o varias condiciones sobre una misma fecha.
Por regla general, (al menos yo), usábamos la función DateValue() para convertir la fecha en un valor de sólo fecha, (no, no es que me esté liando, bueno, un poco sí, pero es que normalmente un tipo de datos fecha (Date) suele incluir la fecha y la hora y con DateValue nos quedamos sólo con la fecha), por la sencilla razón de que esa función la podemos usar tanto "dentro" de la cadena SQL como fuera de ella para convertir el valor de una variable en un dato de tipo fecha, dentr ode un rato veremos un ejemplo.
Pero esto no siempre funciona, por tanto lo más recomendable es que los datos de fechas contenidos en variables, que vayamos a usar en una consulta, la convirtamos en un dato que no de problemas a confusión al motor de la base de datos.
Hasta no hace mucho lo que yo hacía (seguramente recomendado por alguien en algún momento) es convertir la fecha en el formato "americano": #mm/dd/yyyy#, es decir, poner primero el mes, después el día y a continuación el año. Pero esto no siempre funcionaba, incluso si cambiaba el carácter / por - para que la fecha quedara #mm-dd-yyyy#.
Después de mucho probar, la solución que he encontrado es usar el formato de fechas #yyyy/mm/dd#, es decir empezar desde atrás por el año, el mes y el día y todo esto siempre encerrado entre un par de almohadillas (#).

Para que me resulte más fácil, me he creado una función que convierte una fecha en el formato indicado, a esta función la he llamado FechaSQL y es la siguiente:

La función FechaSQL:

Public Function FechaSQL(ByVal vFecha As String) As String
    ' Función para convertir una fecha al formato mm/dd/yy          ( 7/Ago/97)
    ' La fecha la convierte al formato: #yyyy/mm/dd#                (30/May/01)
    '
    On Local Error GoTo SQLDateValErr
    '
    If IsDate(vFecha) Then
        ' si es una fecha válida, convertirla
        FechaSQL = "#" & Format$(vFecha, "yyyy/mm/dd") & "#"
    Else
        ' si no es una fecha válida, devolverlo sin modificar
        FechaSQL = vFecha
    End If
    '
    Exit Function
    '
SQLDateValErr:
    ' Si hay error, la fecha por defecto 1-Ene-1980
    Err = 0
    FechaSQL = "#1980/01/01#"
End Function

Esta función recibe una parámetro que será una fecha válida (o debería serlo), debido a que es posible que el parámetro pasado a la función no sea una fecha válida, se comprueba mediante la función de Visual Basic IsDate(), si es una fecha correcta, la devolvemos en el formato #yyyy/mm/dd#, en caso de que no sea una fecha válida, simplemente devolvemos la misma cadena que hemos recibido en el parámetro.
Si se produjera un error, devolveríamos una fecha ficticia.

Ahora veamos cómo hacía yo antes las consultas.

Nota:
Si no quieres tragarte esta batallita, puedes pasar al código "propuesto" usando la función FechaSQL o bien pasar a ver el ejemplo práctico.

Supongamos que tenemos un campo de una tabla que se llama FechaTérmino (con tilde en la e) y quería comprobar todos los datos entre la fecha actual (o la indicada en la variable fechaActual) y un número de días después, (el número de días estará indicado en la variable cuantosDias), lo que hasta hace poco hacía era esto:

Dim s As String
Dim rs As Recordset
Dim dFin As Date
Dim fechaActual As Date
Dim cuantosDias As Long
'
fechaActual = Format$(txtFecha, "dd/mm/yyyy")
cuantosDias = txtDias
dFin = (fechaActual + cuantosDias)

' la cadena de la consulta SQL
s = "SELECT * FROM Tabla WHERE " & _
    "DateValue([FechaTérmino]) >= " & DateValue(fechaActual) & _
    " AND DateValue([FechaTérmino]) <= " & DateValue(dFin)
' realizar la consulta

' en DAO sería algo así:
' (se supone que Db es del tipo DataBase y ya está instanciada)
Set rs = Db.OpenRecordset(s, dbOpenForwardOnly)

' en ADO sería algo como esto:
' (se supone que cnn es del tipo ADODB.Connection y ya está instanciada)
Set rs = New Recordset
rs.Open s, cnn, adOpenForwardOnly, adLockReadOnly

Pero esto no funciona.
Si quitamos la comparación que hay detrás de AND si funciona, pero entonces nos devolverá todos los registros (filas) que sean igual o posterior a la fecha contenida en fechaActual, por tanto tendríamos que hacer posteriormente un bucle comprobando que las fechas sean inferiores a la fecha indicada en dFin.

Suponiendo que la cadena de la consulta es:

s = "SELECT * FROM Tabla WHERE DateValue([FechaTérmino]) >= " & DateValue(fechaActual)

El bucle que habría que hacer sería algo así:

With rs
    Do While Not .EOF
        ' ¡en ADO no indicar el campo dentro de corchetes!
        If .Fields("[FechaTérmino]") <= DateValue(dFin) Then
            '...
        End If
        .MoveNext
    Loop
End With

Pero esto es trabajo doble... ya que...

Usando la función FechaSQL, podemos hacer la consulta de esta forma:

' la cadena de la consulta SQL, usando FechaSQL
s = "SELECT * FROM Tabla WHERE " & _
    "[FechaTérmino] >= " & FechaSQL(fechaActual) & " AND [FechaTérmino] <= " & FechaSQL(dFin)
 

Y sólo devolverá las filas que estén entre las dos fechas indicadas.

Si estás usando DAO deberás tener en cuenta que para acceder al campo FechaTérmino mediante Fields del recordset, tendrás que usar el nombre de ese campo dentro de corchetes.
Si estás usando ADO no tendrás que usar los corchetes, si lo haces te dará error.

Nota:
Es posible que me haya estado complicando la vida, pero... así es como lo hacía y como lo hago ahora.
De todas formas, te aclaro que no soy ningún experto en bases de datos... así que... es posible que haya mejores formas de hacer lo que te he comentado y lo que te voy a mostrar, así que... no me regañes si sabes cómo hacerlo mejor, simplemente ¡compártelo! (seguramente ya sabrás cómo...)

 

Un ejemplo práctico de todo lo dicho.

Ahora veremos un ejemplo completo de cómo poner todo esto en práctica.
En este ejemplo veremos estas cosillas:

La intención es mostrarte el código relacionado con el acceso a datos tanto para DAO como ADO, por tanto, puedes pulsar en estos links para ver el código de cada una de esas versiones de acceso a datos.

En esos mismos links tienes acceso al código completo.

Aquí te muestro las capturas de los dos formularios usados por los ejemplos.



El formulario para crear la base y los campos con DAO

 



El formulario para crear la base y los campos con ADO



El formulario para realizar la consulta

 

¡Que lo disfrutes!

Nos vemos.
Guillermo


Ejemplo usando DAO:

Este es el código usado para todo lo mencionado en la relación anterior, no se incluye el código de la clase cGetTimer, ya que a dicho código puedes acceder usando el link anteriormente indicado.

Para usar DAO, en referencias tendrás que añadir una a: Microsoft DAO 3.51 Object Library
Para usar el ListView tendrás que añadir el componente: Microsoft Windows Common Controls 6.0 (SP6)

 

Este es el código completo del ejemplo de DAO (fechasDAO.zip 12.0 Bytes)

 

El código del formulario para crear la base y los campos, etc.

'------------------------------------------------------------------------------
' Crear una base de datos DAO                                       (09/Jul/03)
'
' Con el botón de crear la base de datos, se creará una tabla
' con los campos ID, Nombre y FechaTérmino.
' NO BORRAR ESOS CAMPOS para poder probar lo de la consulta.
'
' ©Guillermo 'guille' Som, 2003
'------------------------------------------------------------------------------
Option Explicit

Private sCampos() As String ' Array con los campos en la tabla
'
Private Enum eTamaño
    Nombre = 22&
    Tipo = 10&
    Tamaño = 7&
    AlloZeroLength = 7&
    Required = 6&
End Enum

'------------------------------------------------------------------------------
' Procedimientos privados (no de eventos)
'------------------------------------------------------------------------------
Private Sub crearBase(ByVal sBase As String)
    ' Crear la base de datos indicada
    '
    Dim Db As Database
    Dim Fd As Field
    Dim Tb As TableDef      ' Definir una Tabla
    Dim Idx As Index        ' Para crear un índice
    Dim i As Long
    Dim tVersion As DatabaseTypeEnum
    '
    On Error Resume Next
    'If sBase = "" Then Exit Sub
    i = Len(Dir$(sBase))
    If Err Then i = 1
    If i Then
        MsgBox "La base de datos indicada ya existe." & vbCrLf & _
               "Tendrás que eliminarla antes...", vbCritical
        Exit Sub
    End If
    '
    '--------------------------------------------------------------------------
    ' Crear base de datos, idioma general (dbLangGeneral)
    ' y para la versión indicada del Jet de Access
    '--------------------------------------------------------------------------
    Select Case True
    Case optVersion(0)
        tVersion = dbVersion10
    Case optVersion(1)
        tVersion = dbVersion11
    Case optVersion(2)
        tVersion = dbVersion20
    Case optVersion(3)
        tVersion = dbVersion30
    End Select
    Set Db = CreateDatabase(sBase, dbLangGeneral, tVersion)
    '
    ' Primero la tabla de las tareas
    Set Tb = Db.CreateTableDef(txtTabla.Text)
    ' Vamos a crear el Campo ID que será un índice
    Set Fd = Tb.CreateField("ID", dbLong)
    ' Ahora vamos a asignar las propiedades de contador, etc.
    Fd.Attributes = dbAutoIncrField Or dbUpdatableField Or dbFixedField
    Tb.Fields.Append Fd
    ' El resto de los campos
    Set Fd = Tb.CreateField("Nombre", dbText, 50)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("FechaTérmino", dbDate)
    Tb.Fields.Append Fd
    '
    ' Creamos un índice con el ID
    Set Idx = New Index
    Idx.Name = "PrimaryKey"
    Idx.Unique = True
    Idx.Primary = True
    Idx.Fields = "ID"
    ' Añadimos el índice a la tabla
    Tb.Indexes.Append Idx
    ' Añadimos la tabla a la base
    Db.TableDefs.Append Tb
    '
    ' Cerramos la base
    Db.Close
    '
    MsgBox "Nueva base de datos " & sBase & " creada.", vbInformation
End Sub

Private Function ajusta(ByVal Cadena As String, _
                        ByVal Ancho As Long, _
                        Optional Alineado As AlignmentConstants = vbLeftJustify _
                        ) As String
    ' Ajustar la cadena al ancho especificado
    Dim s As String
    '
    ' Alinear según el parámetro Alineado                           (06/Nov/00)
    s = Left$(Cadena, Ancho)
    If Alineado = vbLeftJustify Then
        s = Left$(s & Space$(Ancho), Ancho)
    ElseIf Alineado = vbRightJustify Then
        s = Right$(Space$(Ancho) & s, Ancho)
    Else
        Do While Len(s) < Ancho
            s = " " & s & " "
        Loop
        s = Left$(s, Ancho)
    End If
    ajusta = s
End Function

Private Sub mostrarCampos(Td As TableDef)
    '--------------------------------------------------------------------------
    ' Inicializar los campos de la tabla especificada
    '--------------------------------------------------------------------------
    Dim Fd As Field
    Dim tIndex As Index
    Dim s As String
    Dim n As Long
    '
    'On Local Error Resume Next
    '
    ' recorrer los campos de la tabla
    n = -1
    '
    List1.Clear
    s = ajusta("Nombre:", eTamaño.Nombre) & " " & ajusta("Tipo:", eTamaño.Tipo) & " " & ajusta("Tamaño:", eTamaño.Tamaño) & " " & ajusta("CeroLen", eTamaño.AlloZeroLength) & " " & ajusta("Requer", eTamaño.Required)
    List1.AddItem s
    s = String$(eTamaño.Nombre, "-") & " " & String$(eTamaño.Tipo, "-") & " " & String$(eTamaño.Tamaño, "-") & " " & String$(eTamaño.AlloZeroLength, "-") & " " & String$(eTamaño.Required, "-")
    List1.AddItem s
    For Each Fd In Td.Fields
        s = ""
        With Fd
            n = n + 1
            ReDim Preserve sCampos(n)
            sCampos(n) = .Name
            '
            s = s & ajusta(.Name, eTamaño.Nombre) & " "
            ' Añadir el "nombre" del tipo
            's = s & ajusta(.Type, eTamaño.Tipo) & " "
            s = s & ajusta(tipoToString(.Type), eTamaño.Tipo) & " "
            s = s & ajusta(CStr(.Size), eTamaño.Tamaño, vbRightJustify) & " "
            s = s & IIf(.AllowZeroLength, "  Sí   ", "  No   ") & " "
            s = s & IIf(.Required, "  Sí  ", "  No  ")
            List1.AddItem s
        End With
    Next
    '
    Err = 0
End Sub

Private Function tipoToString(ByVal elTipo As DataTypeEnum, _
                              Optional ByVal ConTipo As Boolean = False) As String
    ' Devuelve una cadena según el tipo de datos                    (05/Nov/00)
    Dim s As String
    '
    Select Case elTipo
    Case dbBigInt
        s = "dbBigInt"
    Case dbBinary
        s = "dbBinary"
    Case dbBoolean
        s = "dbBoolean"
    Case dbByte
        s = "dbByte"
    Case dbChar
        s = "dbChar"
    Case dbCurrency
        s = "dbCurrency"
    Case dbDate
        s = "dbDate"
    Case dbDecimal
        s = "dbDecimal"
    Case dbDouble
        s = "dbDouble"
    Case dbFloat
        s = "dbFloat"
    Case dbGUID
        s = "dbGUID"
    Case dbInteger
        s = "dbInteger"
    Case dbLong
        s = "dbLong"
    Case dbLongBinary
        s = "dbLongBinary"
    Case dbMemo
        s = "dbMemo"
    Case dbNumeric
        s = "dbNumeric"
    Case dbSingle
        s = "dbSingle"
    Case dbText
        s = "dbText"
    Case dbTime
        s = "dbTime"
    Case dbTimeStamp
        s = "dbTimeStamp"
    Case dbVarBinary
        s = "dbVarBinary"
    Case Else
        'If ConTipo Then
        '    s = "Tipo desconocido"
        'Else
            s = "dbMemo"
        'End If
    End Select
    If ConTipo Then
        s = s & " (" & CStr(elTipo) & ")"
    End If
    tipoToString = s
End Function

Private Sub habilitarCampos(Optional ByVal habilitar As Boolean = True)
    ' habilitar / deshabilitar los controles contenidos en FrameCampos
    Dim tControl As Control
    Dim s As String
    '
    s = FrameCampos.Name
    For Each tControl In Controls
        ' deshabilitar/habilitar sólo los contenidos en el FrameCampos
        If tControl.Container.Name = s Then
            tControl.Enabled = habilitar
        End If
    Next
End Sub
'------------------------------------------------------------------------------

Private Sub cmdAdd_Click()
    ' Añadir el campo indicado a la tabla
    Dim tBase As Database
    Dim tTableDef As TableDef
    Dim tField As Field
    Dim i As Long
    Dim s As String
    '
    On Error GoTo ErrAdd
    '
    Set tBase = OpenDatabase(Me.txtBase)
    Set tTableDef = tBase.TableDefs(txtTabla.Text)
    '
    With Me.cboTipo
        i = .ItemData(.ListIndex)
    End With
    With tTableDef
        Set tField = .CreateField(Me.txtNombre, i, Me.txtLongitud)
        .Fields.Append tField
        With tField '.Fields(txtNombre)
            If Me.chkAllowZeroLength Then
                .AllowZeroLength = True
            Else
                .AllowZeroLength = False
            End If
            If Me.chkRequired Then
                .Required = True
            Else
                .Required = False
            End If
            ' añadirlo a la lista
            s = ajusta(.Name, eTamaño.Nombre) & " "
            s = s & ajusta(tipoToString(.Type), eTamaño.Tipo) & " "
            s = s & ajusta(CStr(.Size), eTamaño.Tamaño, vbRightJustify) & " "
            s = s & IIf(.AllowZeroLength, "  Sí   ", "  No   ") & " "
            s = s & IIf(.Required, "  Sí  ", "  No  ")
            List1.AddItem s
        End With
    End With
    '
    tBase.Close
    '
    Exit Sub
    '
ErrAdd:
    MsgBox "Error al añadir el campo: " & txtNombre & vbCrLf & _
            Err.Number & " " & Err.Description, _
            vbExclamation Or vbOKOnly, "Error al borrar campos"
    tBase.Close
End Sub

Private Sub cmdConsulta_Click()
    With fComprobarFechasDAO
        .NombreBase = txtBase
        .NombreTabla = txtTabla
        .Show vbModal, Me
    End With
End Sub

Private Sub cmdCrearBase_Click()
    crearBase txtBase.Text
End Sub

Private Sub cmdDel_Click()
    ' Eliminar el campo de la tabla
    Dim tBase As Database
    Dim tTableDef As TableDef
    Dim tIndex As Index
    Dim b As Boolean
    Dim i As Long
    '
    On Error GoTo 0 'ErrDel
    '
    Set tBase = OpenDatabase(Me.txtBase)
    Set tTableDef = tBase.TableDefs(txtTabla.Text)
    ' Si es un índice, borrarlo de la tabla de índices              (08/May/01)
    On Error Resume Next
    b = tTableDef.Indexes(Me.txtNombre).Unique
    If Err = 0 Then
        If b = False Then
            tTableDef.Indexes.Delete Me.txtNombre
        Else
            If MsgBox("¡ATENCION! El campo " & txtNombre & " es un índice único." & vbCrLf & "¿Quieres borrarlo?", vbYesNo Or vbExclamation) = vbYes Then
                On Error GoTo ErrDel
                tTableDef.Indexes.Delete Me.txtNombre
            End If
        End If
    End If
    Err = 0
    On Error GoTo ErrDel
    tTableDef.Fields.Delete Me.txtNombre
    '
    ' si llegamos aquí, es que se ha borrado
    ' eliminar el campo de la lista
    For i = 0 To List1.ListCount - 1
        If InStr(List1.List(i), txtNombre) > 0 Then
            List1.RemoveItem i
            Exit For
        End If
    Next
    '
    tBase.Close
    '
    Exit Sub
    '
ErrDel:
    MsgBox "Error al borrar el campo: " & txtNombre & vbCrLf & _
            Err.Number & " " & Err.Description, _
            vbExclamation Or vbOKOnly, "Error al borrar campos"
    tBase.Close
End Sub

Private Sub cmdMostrarCampos_Click()
    ' abrir la tabla señalada por el combo
    Dim Db As Database
    Dim Td As TableDef
    '
    ReDim sCampos(0)
    '
    Set Db = OpenDatabase(txtBase)
    For Each Td In Db.TableDefs
        If Td.Name = txtTabla Then
            ' si es la tabla buscada...
            mostrarCampos Td
            habilitarCampos True
            Exit For
        End If
    Next
    Db.Close
    Set Db = Nothing
End Sub

Private Sub cmdRellenarBase_Click()
    ' rellenar la base de datos con datos ficticios
    Dim i As Long, j As Long
    Dim k As Long, n As Long
    Dim s As String
    Dim cuantosDias As Long
    Dim tDb As Database
    Dim tRs As Recordset
    '
    On Error GoTo ErrRellenar
    '
    ' asegurarnos de que hemos leido los campos
    cmdMostrarCampos_Click
    '
    n = UBound(sCampos)
    If n = 0 Then
        MsgBox "La tabla debería tener al menos dos campos", vbInformation
        Exit Sub
    End If
    '
    Set tDb = OpenDatabase(txtBase)
    s = "SELECT * FROM " & txtTabla
    Set tRs = tDb.OpenRecordset(s, dbOpenDynaset)
    '
    Me.MousePointer = vbHourglass
    DoEvents
    Randomize
    j = txtRegsitros
    For i = 1 To j
        ' crear registros ficticios
        cuantosDias = Int(Rnd * 20) + 20
        With tRs
            .AddNew
            For k = 0 To n
                ' sólo añadir datos en campos de fecha, texto y moneda
                Select Case .Fields(sCampos(k)).Type
                Case DataTypeEnum.dbDate
                    If Rnd > 0.5 Then
                        .Fields(sCampos(k)) = Now + Int(Rnd * cuantosDias)
                    Else
                        .Fields(sCampos(k)) = Now - Int(Rnd * cuantosDias)
                    End If
                Case DataTypeEnum.dbText
                    .Fields(sCampos(k)) = ajusta(sCampos(k) & " " & i, .Fields(sCampos(k)).Size, vbLeftJustify)
                Case DataTypeEnum.dbCurrency
                    .Fields(sCampos(k)) = CCur(Rnd * 15000)
                End Select
            Next
            .Update
        End With
    Next
    '
    tRs.Close
    tDb.Close
    '
    Me.MousePointer = vbDefault
    DoEvents
    MsgBox "Se han añadido " & j & " regsitros a la tabla " & txtTabla, vbInformation
    Exit Sub
    '
ErrRellenar:
    MsgBox "Se ha producido un error:" & vbCrLf & _
            Err.Number & " " & Err.Description, vbCritical, "Error al añadir regsitros"
    Err = 0
End Sub

Private Sub Form_Load()
    Move (Screen.Width - Width) \ 4, 0
    '
    ' Asignar al combo los tipos de datos a elegir
    With cboTipo
        .Clear
        .AddItem "dbText"
        .ItemData(.NewIndex) = DataTypeEnum.dbText
        .AddItem "dbCurrency"
        .ItemData(.NewIndex) = DataTypeEnum.dbCurrency
        .AddItem "dbDate"
        .ItemData(.NewIndex) = DataTypeEnum.dbDate
        .AddItem "dbLong"
        .ItemData(.NewIndex) = DataTypeEnum.dbLong
        .AddItem "dbDouble"
        .ItemData(.NewIndex) = DataTypeEnum.dbDouble
        .AddItem "dbInteger"
        .ItemData(.NewIndex) = DataTypeEnum.dbInteger
        .AddItem "dbBoolean"
        .ItemData(.NewIndex) = DataTypeEnum.dbBoolean
        .AddItem "dbMemo"
        .ItemData(.NewIndex) = DataTypeEnum.dbMemo
        .AddItem "dbByte"
        .ItemData(.NewIndex) = DataTypeEnum.dbByte
        .AddItem "dbChar"
        .ItemData(.NewIndex) = DataTypeEnum.dbChar
        .AddItem "dbLongBinary"
        .ItemData(.NewIndex) = DataTypeEnum.dbLongBinary
        .AddItem "dbSingle"
        .ItemData(.NewIndex) = DataTypeEnum.dbSingle
        .AddItem "dbFloat"
        .ItemData(.NewIndex) = DataTypeEnum.dbFloat
        .AddItem "dbBigInt"
        .ItemData(.NewIndex) = DataTypeEnum.dbBigInt
        .AddItem "dbBinary"
        .ItemData(.NewIndex) = DataTypeEnum.dbBinary
        .AddItem "dbDecimal"
        .ItemData(.NewIndex) = DataTypeEnum.dbDecimal
        .ListIndex = 0
    End With
    txtNombre = "Nombre"
    txtLongitud = "50"
    chkAllowZeroLength.Value = vbChecked
    chkRequired.Value = vbUnchecked
    ' deshabilitar el contenido del Frame1(1)
    habilitarCampos False
End Sub

Private Sub List1_Click()
    ' Mostrar la información del campo seleccionado
    Dim i As Long
    Dim s As String
    '
    With List1
        i = .ListIndex
        If i > 1 Then
            s = .List(i)
            Me.txtNombre = Trim$(Left$(s, eTamaño.Nombre))
            s = LTrim$(Mid$(s, eTamaño.Nombre + 1))
            Me.cboTipo.Text = Trim$(Left$(s, eTamaño.Tipo))
            s = (Mid$(s, eTamaño.Tipo + 2))
            Me.txtLongitud = Trim$(Left$(s, eTamaño.Tamaño))
            s = LTrim$(Mid$(s, eTamaño.Tamaño + 1))
            If Trim$(Left$(s, eTamaño.AlloZeroLength)) = "Sí" Then
                Me.chkAllowZeroLength.Value = vbChecked
            Else
                Me.chkAllowZeroLength.Value = vbUnchecked
            End If
            s = LTrim$(Mid$(s, eTamaño.AlloZeroLength + 1))
            If Trim$(s) = "Sí" Then
                Me.chkRequired.Value = vbChecked
            Else
                Me.chkRequired.Value = vbUnchecked
            End If
        End If
    End With
End Sub

 

El código del formulario para hacer la consulta y mostrar los datos

'------------------------------------------------------------------------------
' Prueba de consulta con fechas en base de datos DAO                (09/Jul/03)
'
' Los campos que debe tener la tabla de la base indicada serán:
'   ID, Nombre y FechaTérmino
'
' ©Guillermo 'guille' Som, 2003
'------------------------------------------------------------------------------
Option Explicit

Public NombreBase As String     ' Nombre de la base de datos
Public NombreTabla As String    ' El nombre de la tabla
Private mCuantosDias As Long
Private Db As Database

Private Sub cmdProcesar_Click()
    ' procesar los datos a mostrar
    Dim fechaActual As Date
    Dim s As String
    Dim dFin As Date
    Dim tRs As Recordset
    Dim tGT As cGetTimer
    Dim n As Long
    '
    On Error Resume Next
    Set Db = OpenDatabase(NombreBase)
    If Err Then
        MsgBox "Error al abrir la base de datos: " & NombreBase & vbCrLf & _
                Err.Number & " " & Err.Description
        Exit Sub
    End If
    '
    fechaActual = Format$(txtFecha, "dd/mm/yyyy")
    mCuantosDias = txtDias
    dFin = (fechaActual + mCuantosDias)
    '
    ListView1.ListItems.Clear
    '
    Set tGT = New cGetTimer
    tGT.StartTimer
    '
    n = 0
    Err.Number = 0
    s = "SELECT ID, Nombre, [FechaTérmino] FROM " & NombreTabla & " WHERE [FechaTérmino] >= " & FechaSQL(fechaActual) & " AND [FechaTérmino] <= " & FechaSQL(dFin) & " ORDER BY [FechaTérmino]"
    Set tRs = Db.OpenRecordset(s, dbOpenForwardOnly)
    If Err Then
        MsgBox "Error al abrir el Recordset" & vbCrLf & _
                Err.Number & " " & Err.Description
        Exit Sub
    End If
    With tRs
        If (.EOF = True) And (.BOF = True) Then
            ' Si no hay datos...
            With ListView1.ListItems.Add(, , "0")
                .SubItems(1) = "No hay datos entre las fechas " & Format$(fechaActual, "dd/mm/yyyy")
                .SubItems(2) = Format$(dFin, "dd/mm/yyyy")
            End With
        Else
            n = 0
            Do While Not .EOF
                n = n + 1
                With ListView1.ListItems.Add(, , tRs.Fields("ID"))
                    .SubItems(1) = Trim$(tRs.Fields("Nombre"))
                    .SubItems(2) = Format$(tRs.Fields("[FechaTérmino]") & "", "dd/mm/yyyy")
                End With
                .MoveNext
            Loop
        End If
    End With
    tRs.Close
    Db.Close
    '
    tGT.StopTimer
    lblInfo.Caption = "Tiempo: " & tGT.ElapsedTime & " (" & n & ")"
End Sub

Private Sub Form_Load()
    ' Asignar el nombre de la base de datos
    'NombreBase App.Path & "PruebaDAO.mdb"
    '
    If Year(Now) > 2003 Then
        lblInfo.Caption = "©Guillermo 'guille' Som, 2003-" & Year(Now)
    Else
        lblInfo.Caption = "©Guillermo 'guille' Som, 2003"
    End If
    '
    mCuantosDias = 10&
    txtDias.Text = mCuantosDias
    '
    ' crear las columnas del ListView
    ' (aunque ya están creadas en tiempo de diseño)
    With ListView1
        .ColumnHeaders.Clear
        .ColumnHeaders.Add , , "ID", 800
        .ColumnHeaders.Add , , "Nombre", 3200
        .ColumnHeaders.Add , , "Fecha Término", 1400, lvwColumnRight
        .GridLines = True
        .FullRowSelect = True
        .LabelEdit = lvwManual
    End With
End Sub

 


Ejemplo usando ADO:

Este es el código usado para todo lo mencionado en la relación anterior, no se incluye el código de la clase cGetTimer, ya que a dicho código puedes acceder usando el link anteriormente indicado.

Para usar ADO, en referencias tendrás que añadir una a: Microsoft ActiveX Data Objects 2.5 Library
Además de una a ADOX: Microsoft ADO Ext. 2.7 for DDL and Security
(la versión pude ser cualquier otra anterior a la 2.7)
Para usar el ListView tendrás que añadir el componente: Microsoft Windows Common Controls 6.0 (SP6)

Nota:
He de aclarar que para mi gusto, este código no está terminado, ya que, por ejemplo, los tipos de datos no están "comprobados", simplemente los he sustituido "a mocho".

Además, (y esto es más grave), que con el motor 3.51 (el compatible con Access 97) no he logrado crear un campo Auntonumérico, sin embargo usando el 4.0 si que se crea sin problemas...
Lo mismo es que estoy demasiado "ofuscado", en fin... a ver si con más calma o con la ayuda de alguna alma caritativa lo dejo solucionado...

 


Nota del 10/Jul/03:

Pues la aparición del alma caritativa no se ha hecho esperar, gracias a Joaquín Delgado Pastor, tenemos la solución.
Y esta consiste en lo siguiente:
-Usar siempre el proveedor Microsoft.Jet.OLEDB.4.0
-Añadir esta cadena a la cadena de conexión:
    -Para Access 97: Jet OLEDB:Engine Type=4;
    -Para Access 2000: Jet OLEDB:Engine Type=5;
De esta forma se creará correctamente el campo autonumérico y según se seleccione la opción 3.51 o 4.0 se creará una base de datos compatible con Access 97 o Access 2000/XP respectivamente.

En el código mostrado están hechas las correcciones correspondientes para usar este nueva forma.

Si quieres, ahora en los dos Options en lugar de indicar el "motor" Jet, se puede indicar si será con formato Access 97 o con formato Access 2000/XP.
En el código incluido en el Zip ya está modificado.

 

Este es el código completo del ejemplo de ADO (fechasADO.zip 12.8 KB)

El código del formulario para crear la base y los campos, etc.

'------------------------------------------------------------------------------
' Crear una base de datos ADO                                       (09/Jul/03)
'
' Con el botón de crear la base de datos, se creará una tabla
' con los campos ID, Nombre y FechaTérmino.
' NO BORRAR ESOS CAMPOS para poder probar lo de la consulta.
'
' ©Guillermo 'guille' Som, 2003
'------------------------------------------------------------------------------
Option Explicit

Private sProvider As String
Private sCampos() As String ' Array con los campos en la tabla
'
Private Enum eTamaño
    Nombre = 22&
    Tipo = 10&
    Tamaño = 7&
    AlloZeroLength = 7&
    Required = 6&
End Enum

'------------------------------------------------------------------------------
' Procedimientos privados (no de eventos)
'------------------------------------------------------------------------------

Private Sub crearBase(ByVal sBase As String)
    ' Crear la base de datos indicada
    '
    Dim i As Long
    '
    Dim tbl As ADOX.Table
    Dim cat As ADOX.Catalog
    Dim idx As ADOX.Index
    Dim col As ADOX.Column
    '
    Dim sProviderDes As String
    '
    On Error Resume Next
    '
    'If sBase = "" Then Exit Sub
    i = Len(Dir$(sBase))
    If Err Then i = 1
    If i Then
        MsgBox "La base de datos indicada ya existe." & vbCrLf & _
               "Tendrás que eliminarla antes...", vbCritical
        Exit Sub
    End If
    '
    On Error GoTo 0
    '
    ' Gracias a Joaquin Delgado Pastor (10/Jul/03), con esto funciona:
    '
    Select Case True
    Case Me.optVersion(0)
        'sProvider = "Microsoft.Jet.OLEDB.3.51"
        '
        sProviderDes = "Jet OLEDB:Engine Type=4;"

    Case Me.optVersion(1)
        'sProvider = "Microsoft.Jet.OLEDB.4.0"
        sProviderDes = "Jet OLEDB:Engine Type=5;"

    End Select
    sProvider = "Microsoft.Jet.OLEDB.4.0"
    '
    ' Crear la base de datos
    Set cat = New ADOX.Catalog
    cat.Create "Provider=" & sProvider & ";" & _
               "Data Source=" & txtBase & ";" & sProviderDes
    '
    Set cat = New ADOX.Catalog
    Set tbl = New ADOX.Table
    '
    ' Abrir el catálogo
    cat.ActiveConnection = _
            "Provider=" & sProvider & ";" & _
            "Data Source=" & txtBase & ";"
    '
    ' Crear la nueva tabla
    With tbl
        .Name = txtTabla.Text
        ' Crear los campos y añadirlos a la tabla.
        ' Esto hay que hacerlo antes de añadir la tabla a la colección de tablas
        Set col = New ADOX.Column
        With col
            .Name = "ID"
            .Type = adInteger
            ' Autoincrement no existe como propiedad en 3.51
            If sProvider <> "Microsoft.Jet.OLEDB.3.51" Then
                Set .ParentCatalog = cat
                .Properties("AutoIncrement") = True
            End If
        End With
        .Columns.Append col
        '
        '
        Set idx = New ADOX.Index
        idx.Name = "IDx"
        idx.PrimaryKey = True
        idx.Unique = True
        idx.IndexNulls = adIndexNullsDisallow
        idx.Columns.Append "ID"
        .Indexes.Append idx
        '
        '
        ' Dependiendo del tipo de proveedor, los datos de cadena serán de un tipo u otro
        If sProvider = "Microsoft.Jet.OLEDB.3.51" Then
            ' Para Access 97
            .Columns.Append "Nombre", adVarChar, 50         ' Una cadena de 50 caracteres
            .Columns.Append "FechaTérmino", adDate
        Else
            ' Para Access 2000
            .Columns.Append "Nombre", adVarWChar, 50        ' Una cadena de 50 caracteres
            .Columns.Append "FechaTérmino", adDate
        End If
        .Columns("Nombre").Attributes = adColNullable       ' Permite contener nulos
        .Columns("FechaTérmino").Attributes = adColNullable
    End With
    '
    ' Añadir la nueva tabla a la base de datos
    cat.Tables.Append tbl
    '
    Set tbl = Nothing
    Set cat = Nothing
    '
    '
    MsgBox "Nueva base de datos " & sBase & " creada.", vbInformation
End Sub

Private Function ajusta(ByVal Cadena As String, _
                        ByVal Ancho As Long, _
                        Optional Alineado As AlignmentConstants = vbLeftJustify _
                        ) As String
    ' Ajustar la cadena al ancho especificado
    Dim s As String
    '
    ' Alinear según el parámetro Alineado                           (06/Nov/00)
    s = Left$(Cadena, Ancho)
    If Alineado = vbLeftJustify Then
        s = Left$(s & Space$(Ancho), Ancho)
    ElseIf Alineado = vbRightJustify Then
        s = Right$(Space$(Ancho) & s, Ancho)
    Else
        Do While Len(s) < Ancho
            s = " " & s & " "
        Loop
        s = Left$(s, Ancho)
    End If
    ajusta = s
End Function

Private Sub mostrarCampos(Td As Table)
    '--------------------------------------------------------------------------
    ' Inicializar los campos de la tabla especificada
    '--------------------------------------------------------------------------
    Dim Fd As Column
    Dim s As String
    Dim n As Long
    '
    'On Local Error Resume Next
    '
    ' recorrer los campos de la tabla
    n = -1
    '
    List1.Clear
    s = ajusta("Nombre:", eTamaño.Nombre) & " " & ajusta("Tipo:", eTamaño.Tipo) & " " & ajusta("Tamaño:", eTamaño.Tamaño) & " " & ajusta("CeroLen", eTamaño.AlloZeroLength) & " " & ajusta("Requer", eTamaño.Required)
    List1.AddItem s
    s = String$(eTamaño.Nombre, "-") & " " & String$(eTamaño.Tipo, "-") & " " & String$(eTamaño.Tamaño, "-") & " " & String$(eTamaño.AlloZeroLength, "-") & " " & String$(eTamaño.Required, "-")
    List1.AddItem s
    For Each Fd In Td.Columns
        s = ""
        With Fd
            n = n + 1
            ReDim Preserve sCampos(n)
            sCampos(n) = .Name
            '
            s = s & ajusta(.Name, eTamaño.Nombre) & " "
            ' Añadir el "nombre" del tipo
            's = s & ajusta(.Type, eTamaño.Tipo) & " "
            s = s & ajusta(tipoToString(.Type), eTamaño.Tipo) & " "
            s = s & ajusta(CStr(.DefinedSize), eTamaño.Tamaño, vbRightJustify) & " "
            s = s & IIf((.Attributes And adColNullable) = adColNullable, "  Sí   ", "  No   ") & " "
            s = s & IIf((.Attributes And adIndexNullsAllow) = adIndexNullsAllow, "  Sí  ", "  No  ")
            List1.AddItem s
        End With
    Next
    '
    Err = 0
End Sub

Private Function tipoToString(ByVal elTipo As DataTypeEnum, _
                              Optional ByVal ConTipo As Boolean = False) As String
    ' Devuelve una cadena según el tipo de datos                    (05/Nov/00)
    Dim s As String
    '
    Select Case elTipo
    Case DataTypeEnum.adBigInt
        s = "adBigInt"
    Case DataTypeEnum.adBinary
        s = "adBinary"
    Case DataTypeEnum.adBoolean
        s = "adBoolean"
    Case DataTypeEnum.adChar
        s = "adChar"
    Case DataTypeEnum.adVarChar
        s = "adVarChar"
    Case DataTypeEnum.adCurrency
        s = "adCurrency"
    Case DataTypeEnum.adDate
        s = "adDate"
    Case DataTypeEnum.adDecimal
        s = "adDecimal"
    Case DataTypeEnum.adDouble
        s = "adDouble"
    Case DataTypeEnum.adSingle
        s = "adSingle"
    Case DataTypeEnum.adGUID
        s = "adGUID"
    Case DataTypeEnum.adInteger
        s = "adInteger"
    Case DataTypeEnum.adNumeric
        s = "adNumeric"
    Case DataTypeEnum.adLongVarBinary
        s = "adLongVarBinary"
    Case DataTypeEnum.adNumeric
        s = "adNumeric"
    Case DataTypeEnum.adSingle
        s = "adSingle"
    Case DataTypeEnum.adDBTime
        s = "adDBTime"
    Case DataTypeEnum.adDBDate
        s = "adDBDate"
    Case DataTypeEnum.adVarBinary
        s = "adVarBinary"
    Case Else
        s = "adVarChar"
    End Select
    If ConTipo Then
        s = s & " (" & CStr(elTipo) & ")"
    End If
    tipoToString = s
End Function

Private Sub habilitarCampos(Optional ByVal habilitar As Boolean = True)
    ' habilitar / deshabilitar los controles contenidos en FrameCampos
    Dim tControl As Control
    Dim s As String
    '
    s = FrameCampos.Name
    For Each tControl In Controls
        ' deshabilitar/habilitar sólo los contenidos en el FrameCampos
        If tControl.Container.Name = s Then
            tControl.Enabled = habilitar
        End If
    Next
End Sub
'------------------------------------------------------------------------------

Private Sub cmdAdd_Click()
    ' Añadir el campo indicado a la tabla
    Dim i As Long
    Dim s As String
    Dim cat As ADOX.Catalog
    Dim tTable As ADOX.Table
    'Dim col As ADOX.Column
    '
    On Error GoTo ErrAdd
    '
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = "Provider=" & sProvider & "; Data Source=" & txtBase.Text
    Set tTable = cat.Tables(txtTabla.Text)
    '
    With Me.cboTipo
        i = .ItemData(.ListIndex)
    End With
    With tTable
        .Columns.Append txtNombre, i, txtLongitud
        With .Columns(txtNombre)
            If Me.chkAllowZeroLength Then
                .Attributes = adColNullable
            End If
            ' añadirlo a la lista
            s = ajusta(.Name, eTamaño.Nombre) & " "
            s = s & ajusta(tipoToString(.Type), eTamaño.Tipo) & " "
            s = s & ajusta(CStr(.DefinedSize), eTamaño.Tamaño, vbRightJustify) & " "
            s = s & IIf((.Attributes And adColNullable) = adColNullable, "  Sí   ", "  No   ") & " "
            s = s & " " 'IIf(.Required, "  Sí  ", "  No  ")
            List1.AddItem s
        End With
    End With
    '
    Set tTable = Nothing
    Set cat = Nothing
    '
    Exit Sub
    '
ErrAdd:
    MsgBox "Error al añadir el campo: " & txtNombre & vbCrLf & _
            Err.Number & " " & Err.Description, _
            vbExclamation Or vbOKOnly, "Error al borrar campos"
End Sub

Private Sub cmdConsulta_Click()
    Load fComprobarFechasADO
    With fComprobarFechasADO
        .NombreBase = txtBase
        .NombreTabla = txtTabla
        .Provider = sProvider
        .Show vbModal, Me
    End With
End Sub

Private Sub cmdCrearBase_Click()
    crearBase txtBase.Text
End Sub

Private Sub cmdDel_Click()
    ' Eliminar el campo de la tabla
    Dim b As Boolean
    Dim i As Long
    Dim cat As ADOX.Catalog
    Dim tTable As ADOX.Table
    Dim col As ADOX.Column
    '
    '
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = "Provider=" & sProvider & "; Data Source=" & txtBase.Text
    Set tTable = cat.Tables(txtTabla.Text)
    '
    '
    ' Si es un índice, borrarlo de la tabla de índices              (08/May/01)
    On Error Resume Next
    b = tTable.Indexes(txtNombre).Unique
    If Err = 0 Then
        If b = False Then
            tTable.Indexes.Delete txtNombre
        Else
            If MsgBox("¡ATENCION! El campo " & txtNombre & " es un índice único." & vbCrLf & "¿Quieres borrarlo?", vbYesNo Or vbExclamation) = vbYes Then
                On Error GoTo ErrDel
                tTable.Indexes.Delete txtNombre
            End If
        End If
    End If
    Err = 0
    On Error GoTo ErrDel
    tTable.Columns.Delete txtNombre
    '
    ' si llegamos aquí, es que se ha borrado
    ' eliminar el campo de la lista
    For i = 0 To List1.ListCount - 1
        If InStr(List1.List(i), txtNombre) > 0 Then
            List1.RemoveItem i
            Exit For
        End If
    Next
    '
    Set tTable = Nothing
    Set cat = Nothing
    '
    Exit Sub
    '
ErrDel:
    MsgBox "Error al borrar el campo: " & txtNombre & vbCrLf & _
            Err.Number & " " & Err.Description, _
            vbExclamation Or vbOKOnly, "Error al borrar campos"
End Sub

Private Sub cmdMostrarCampos_Click()
    ' abrir la tabla señalada por el combo
    Dim cat As ADOX.Catalog
    Dim tTable As ADOX.Table
    '
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = "Provider=" & sProvider & "; Data Source=" & txtBase.Text
    Set tTable = cat.Tables(txtTabla.Text)
    '
    ReDim sCampos(0)
    '
    mostrarCampos tTable
    habilitarCampos True
    '
    Set tTable = Nothing
    Set cat = Nothing
End Sub

Private Sub cmdRellenarBase_Click()
    ' rellenar la base de datos con datos ficticios
    Dim i As Long, j As Long
    Dim k As Long, n As Long
    Dim s As String
    Dim cuantosDias As Long
    Dim cnn As ADODB.Connection
    Dim tRs As ADODB.Recordset
    '
    'On Error GoTo ErrRellenar
    On Error GoTo 0
    '
    ' asegurarnos de que hemos leido los campos
    cmdMostrarCampos_Click
    '
    n = UBound(sCampos)
    If n = 0 Then
        MsgBox "La tabla debería tener al menos dos campos", vbInformation
        Exit Sub
    End If
    '
    Set cnn = New ADODB.Connection
    cnn.Open "Provider=" & sProvider & "; Data Source=" & txtBase
    s = "SELECT * FROM " & txtTabla
    Set tRs = New Recordset
    tRs.Open s, cnn, adOpenDynamic, adLockOptimistic
    '
    Me.MousePointer = vbHourglass
    DoEvents
    Randomize
    j = txtRegsitros
    For i = 1 To j
        ' crear registros ficticios
        cuantosDias = Int(Rnd * 20) + 20
        With tRs
            .AddNew
            For k = 0 To n
                ' sólo añadir datos en campos de fecha, texto y moneda
                Select Case .Fields(sCampos(k)).Type
                Case DataTypeEnum.adDate
                    If Rnd > 0.5 Then
                        .Fields(sCampos(k)) = Now + Int(Rnd * cuantosDias)
                    Else
                        .Fields(sCampos(k)) = Now - Int(Rnd * cuantosDias)
                    End If
                Case DataTypeEnum.adVarChar, DataTypeEnum.adVarWChar
                    .Fields(sCampos(k)) = ajusta(sCampos(k) & " " & i, .Fields(sCampos(k)).DefinedSize, vbLeftJustify)
                Case DataTypeEnum.adCurrency
                    .Fields(sCampos(k)) = CCur(Rnd * 15000)
                End Select
            Next
            .Update
        End With
    Next
    '
    Set tRs = Nothing
    cnn.Close
    '
    Me.MousePointer = vbDefault
    DoEvents
    MsgBox "Se han añadido " & j & " regsitros a la tabla " & txtTabla, vbInformation
    Exit Sub
    '
ErrRellenar:
    MsgBox "Se ha producido un error:" & vbCrLf & _
            Err.Number & " " & Err.Description, vbCritical, "Error al añadir regsitros"
    Err = 0
End Sub

Private Sub Form_Load()
    Move (Screen.Width - Width) \ 4, 0
    '
    'txtBase = App.Path & "\PruebaDAO.mdb"
    txtBase = "PruebaADO.mdb"
    'sProvider = "Microsoft.Jet.OLEDB.3.51"
    ' con el proveedor 4.0 el autoincremento no da error
    sProvider = "Microsoft.Jet.OLEDB.4.0"
    '
    ' Asignar al combo los tipos de datos a elegir
    With cboTipo
        .Clear
        ' Tipos de datos de DAO y ADO (equivalencias)
        'dbBinary       adBinary
        'dbBoolean      adBoolean
        'dbByte         adUnsignedTinyInt
        'dbCurrency     adCurrency
        'dbDate         adDate
        'dbDecimal      adNumeric
        'dbDouble       adDouble
        'dbGUID         adGUID
        'dbInteger      adSmallInt
        'dbLong         adInteger
        'dbLongBinary   adLongVarBinary
        'dbMemo         adLongVarWChar
        'dbSingle       adSingle
        'dbText         adVarWChar
        .AddItem tipoToString(DataTypeEnum.adVarChar)
        .ItemData(.NewIndex) = DataTypeEnum.adVarChar
        .AddItem "adCurrency"
        .ItemData(.NewIndex) = DataTypeEnum.adCurrency
        .AddItem "adDate"
        .ItemData(.NewIndex) = DataTypeEnum.adDate
        .AddItem "adNumeric"
        .ItemData(.NewIndex) = DataTypeEnum.adNumeric
        .AddItem "adDouble"
        .ItemData(.NewIndex) = DataTypeEnum.adDouble
        .AddItem "adInteger"
        .ItemData(.NewIndex) = DataTypeEnum.adInteger
        .AddItem "adBoolean"
        .ItemData(.NewIndex) = DataTypeEnum.adBoolean
        .AddItem "adVarBinary"
        .ItemData(.NewIndex) = DataTypeEnum.adVarBinary
        .AddItem "adChar"
        .ItemData(.NewIndex) = DataTypeEnum.adChar
        .AddItem "adSingle"
        .ItemData(.NewIndex) = DataTypeEnum.adSingle
        .AddItem "adBigInt"
        .ItemData(.NewIndex) = DataTypeEnum.adBigInt
        .AddItem "adBinary"
        .ItemData(.NewIndex) = DataTypeEnum.adBinary
        .AddItem "adDecimal"
        .ItemData(.NewIndex) = DataTypeEnum.adDecimal
        .ListIndex = 0
    End With
    txtNombre = "Nombre"
    txtLongitud = "50"
    chkAllowZeroLength.Value = vbChecked
    chkRequired.Value = vbUnchecked
    ' deshabilitar el contenido del Frame1(1)
    habilitarCampos False
End Sub

Private Sub List1_Click()
    ' Mostrar la información del campo seleccionado
    Dim i As Long
    Dim s As String
    '
    With List1
        i = .ListIndex
        If i > 1 Then
            s = .List(i)
            Me.txtNombre = Trim$(Left$(s, eTamaño.Nombre))
            s = LTrim$(Mid$(s, eTamaño.Nombre + 1))
            Me.cboTipo.Text = Trim$(Left$(s, eTamaño.Tipo))
            s = (Mid$(s, eTamaño.Tipo + 2))
            Me.txtLongitud = Trim$(Left$(s, eTamaño.Tamaño))
            s = LTrim$(Mid$(s, eTamaño.Tamaño + 1))
            If Trim$(Left$(s, eTamaño.AlloZeroLength)) = "Sí" Then
                Me.chkAllowZeroLength.Value = vbChecked
            Else
                Me.chkAllowZeroLength.Value = vbUnchecked
            End If
            s = LTrim$(Mid$(s, eTamaño.AlloZeroLength + 1))
            If Trim$(s) = "Sí" Then
                Me.chkRequired.Value = vbChecked
            Else
                Me.chkRequired.Value = vbUnchecked
            End If
        End If
    End With
End Sub

Private Sub optVersion_Click(Index As Integer)
    If Index = 0 Then
        sProvider = "Microsoft.Jet.OLEDB.3.51"
    Else
        sProvider = "Microsoft.Jet.OLEDB.4.0"
    End If
End Sub

 

El código del formulario para hacer la consulta y mostrar los datos

'------------------------------------------------------------------------------
' Prueba de consulta con fechas en base de datos ADO                (09/Jul/03)
'
' Los campos que debe tener la tabla de la base indicada serán:
'   ID, Nombre y FechaTérmino
'
' ©Guillermo 'guille' Som, 2003
'------------------------------------------------------------------------------
Option Explicit

Public NombreBase As String     ' Nombre de la base de datos
Public NombreTabla As String    ' El nombre de la tabla
Public Provider As String
Private mCuantosDias As Long
' Objetos para acceder directamente a la base usando código
Private cnn As ADODB.Connection

Private Sub cmdProcesar_Click()
    ' procesar los datos a mostrar
    Dim fechaActual As Date
    Dim s As String
    Dim dFin As Date
    Dim tRs As Recordset
    Dim tGT As cGetTimer
    Dim n As Long
    '
    Set cnn = New ADODB.Connection
    '
    cnn.Open "Provider=" & Provider & "; Data Source=" & NombreBase
    '
    fechaActual = Format$(txtFecha, "dd/mm/yyyy")
    mCuantosDias = txtDias
    dFin = (fechaActual + mCuantosDias)
    '
    ListView1.ListItems.Clear
    '
    Set tGT = New cGetTimer
    tGT.StartTimer
    '
    ' en ADO no hace falta indicar el campo FechaTérmino entre corchetes
    s = "SELECT ID, Nombre, [FechaTérmino] FROM " & NombreTabla & " WHERE [FechaTérmino] >= " & FechaSQL(fechaActual) & " AND [FechaTérmino] <= " & FechaSQL(dFin) & " ORDER BY [FechaTérmino]"
    Set tRs = New Recordset
    tRs.Open s, cnn, adOpenForwardOnly, adLockReadOnly 'adLockOptimistic
    With tRs
        If (.EOF = True) And (.BOF = True) Then
            ' Si no hay datos...
            With ListView1.ListItems.Add(, , "0")
                .SubItems(1) = "No hay datos entre las fechas " & Format$(fechaActual, "dd/mm/yyyy")
                .SubItems(2) = Format$(dFin, "dd/mm/yyyy")
            End With
        Else
            n = 0
            Do While Not .EOF
                n = n + 1
                With ListView1.ListItems.Add(, , tRs.Fields("ID"))
                    .SubItems(1) = Trim$(tRs.Fields("Nombre") & "")
                    .SubItems(2) = Format$(tRs.Fields("FechaTérmino") & "", "dd/mm/yyyy")
                End With
                .MoveNext
            Loop
        End If
    End With
    tRs.Close
    cnn.Close
    '
    tGT.StopTimer
    lblInfo.Caption = "Tiempo: " & tGT.ElapsedTime & " (" & n & ")"
End Sub

Private Sub Form_Load()
    ' Asignar el nombre de la base de datos y el proveedor
    '
    ' para bases de datos Access 97 (con Access 2000/XP no funciona)
    NombreBase = App.Path & "\PruebaDAO.mdb"
    Provider = "Microsoft.Jet.OLEDB.3.51"
    '
    ' para bases de datos Access 2000 (también para Access 97, pero va más lento)
    'NombreBase = App.Path & "PruebaDAO.mdb"
    'sProvider = "Microsoft.Jet.OLEDB.4.0"
    '
    If Year(Now) > 2003 Then
        lblInfo.Caption = "©Guillermo 'guille' Som, 2003-" & Year(Now)
    Else
        lblInfo.Caption = "©Guillermo 'guille' Som, 2003"
    End If
    '
    mCuantosDias = 10&
    txtDias.Text = mCuantosDias
    '
    ' crear las columnas del ListView
    ' (aunque ya están creadas en tiempo de diseño)
    With ListView1
        .ColumnHeaders.Clear
        .ColumnHeaders.Add , , "ID", 800
        .ColumnHeaders.Add , , "Nombre", 3200
        .ColumnHeaders.Add , , "Fecha Término", 1400, lvwColumnRight
        .GridLines = True
        .FullRowSelect = True
        .LabelEdit = lvwManual
    End With
End Sub

ir al índice