Un Gran Proyecto, Paso a Paso

Tercera Entrega (7/Mar/97)

Pulsa aquí, para ver la Primera Entrega
Nota: Deberías verla, porque ha habido cambios
Pulsa aquí, para ver la Segunda Entrega
Recomendable para poder seguir el hilo (que no thread)

En la entrega anterior, (si lo sé hoy no es el mañana al que me refería... pero recuerda que hubo quién dijo: ...como decíamos ayer... y habían pasado 7 u 8 años... así, que por cinco días...), te comentaba que no se hacíacomprobación de que la extensión fuese la adecuada. Vamos a trabajar con bases de Access, así que la extensión debe ser MDB, por tanto, vamos a añadir las siguientes líneas a la rutina cmdAceptar_Click() del formulario de Entrada, y las pones después del On Local Error... (Más abajo está el código completo de cmdAceptar)

If InStr(sUserBase, ".mdb") = 0 Then
    MsgBox "Atención la base especificada no tiene extensión MDB", vbInformation, cMsg
    'Posicionarse en el Text1
    Text1.SetFocus
    Exit Sub
End If

Private Sub CrearBase(sBase As String)
    'Crear la base de datos indicada
    '
    Dim Db As Database
    Dim Fd As Field
    Dim Tb As New TableDef      'Definir una Tabla
    Dim Idx As New Index        'Para crear un índice
    Dim i As Integer
    
    'Crear base de datos, idioma español y para la versión 2.0 del Jet de Access
    '================================================================================
    'Si vas a adaptar este programa para VB3, usa dbVersion11 en lugar de dbVersion20
    '================================================================================
    Set Db = CreateDatabase(sBase, dbLangSpanish, dbVersion20)
    '
    'La constante dbVersion20 no aparece en la ayuda, en su lugar lo hace la dbVersion25
    'pero ésa no está creada!!!
    '
    'Primero la tabla de las tareas
    Set Tb = Db.CreateTableDef("Tareas")
    'Vamos a crear cada uno de los campos
    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("Fecha", dbDate)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Asunto", dbText, 255)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Descripcion", dbMemo)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("FechaInicio", dbDate)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("FechaTermino", dbDate)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Terminada", dbInteger)
    Tb.Fields.Append Fd
    'Creamos un índice con el ID
    Idx.Name = "PrimaryKey"
    Idx.Unique = True
    Idx.Primary = True
    Idx.Fields = "ID"
    Tb.Indexes.Append Idx
    'Añadimos la tabla a la base
    Db.TableDefs.Append Tb
    '
    'Creamos la otra tabla: Anotaciones
    Set Tb = Db.CreateTableDef("Anotaciones")
    'El campo ID, es el contador, etc.
    Set Fd = Tb.CreateField("ID", dbLong)
    Fd.Attributes = dbAutoIncrField Or dbUpdatableField Or dbFixedField
    Tb.Fields.Append Fd
    'El resto de los campos
    Set Fd = Tb.CreateField("Fecha", dbDate)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Tema", dbText, 50)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Asunto", dbText, 255)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Medio", dbText, 255)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Localizacion", dbText, 255)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Descripcion", dbMemo)
    Tb.Fields.Append Fd
    Set Fd = Tb.CreateField("Detalle", dbLongBinary)
    Tb.Fields.Append Fd
    'Creamos un índice con el ID
    Set Idx = Nothing           'Quitar la referencia anterior
    Idx.Name = "PrimaryKey"
    Idx.Unique = True
    Idx.Primary = True
    Idx.Fields = "ID"
    Tb.Indexes.Append Idx
    'Añadimos la segunda tabla a la base
    Db.TableDefs.Append Tb
    'Cerramos la base
    Db.Close
    
    MsgBox "Nueva base de datos " & sBase & " creada.", vbInformation
End Sub

Private Sub cmdAceptar_Click()
    Dim sPath As String                         'path de la base especificada
    Dim sUserPath As String                     'path del usuario
    Dim sUserBase As String                     'nombre de la base del usuario
    Const cMsg = "Seleccionar la base"          'Constante para los MsgBox
    Dim numBases As Integer                     'Número de bases
    Dim sTmp As String                          'varios usos
    Dim i As Integer                            'variable del bucle
    
    'Comprobar si hay datos introducidos
    sUsuario = Trim$(Text1)
    If Len(sUsuario) = 0 Then
        MsgBox "Debes especificar el nombre del usuario.", vbInformation, cMsg
        'Posicionarse en el Text1
        Text1.SetFocus
        Exit Sub
    End If
    sTmp = Trim$(Combo1.Text)
    If Len(sTmp) = 0 Then
        MsgBox "No hay ninguna base de datos seleccionada.", vbInformation, cMsg
        Combo1.SetFocus
        Exit Sub
    End If
    
    'Separar los datos del path y nombre del archivo
    SplitPath sTmp, sPath, sBase
    
    'Comprobar si la base existe en el combo
    '   Si no existe, añadirla al combo
    i = ActualizarLista(sBase, Combo1)
    If i = -1 Then
        'Este caso seguramente nunca se dará, pero...
        MsgBox "Se ha producido un error inesperado al añadir al combo", vbCritical, cMsg
        Unload Me
        End
    End If
    
    'Esta base, hay que buscarla en las del usuario especificado
    'el formato será usuarioXX=path_de_la_base
    sTmp = sUsuario & Format$(i + 1, "00")
    'Comprobar si no se ha especificado el path
    sUserPath = sPath
    If sPath = "" Then
        'para tomar el que hubiese de antes.
        sUserPath = Trim$(LeerIni(ficIni, "General", sTmp, sPath))
    End If
    sUserBase = sUserPath & "\" & sBase
    
    'Por si la ruta es errónea
    On Local Error Resume Next
    
    If InStr(sUserBase, ".mdb") = 0 Then
        MsgBox "Atención la base especificada no tiene extensión MDB", vbInformation, cMsg
        'Posicionarse en el Text1
        Text1.SetFocus
        Exit Sub
    End If
        
    'Comprobar si existe "fisicamente" la base
    If Len(Dir$(sUserBase)) = 0 Then
        'No existe, preguntar si se crea
        If MsgBox("La base especificada no existe." & vbCrLf & "'" & sUserBase & "'" & vbCrLf & "¿Quieres crearla?", vbQuestion + vbYesNo, cMsg) = vbYes Then
            On Local Error GoTo 0       'Si se produce un error, que se pare!
            'Crear la base
            CrearBase sUserBase
        Else
            Combo1.SetFocus
            Exit Sub
        End If
    End If
    If Err Then
        MsgBox "Seguramente la ruta especificada, es errónea:" & vbCrLf & "'" & sUserBase & "'", vbInformation, cMsg
        Combo1.SetFocus
        Exit Sub
    End If
    
    On Local Error GoTo 0           'Si se produce un error, que se pare!
    
    'Guardar los datos de configuración
    GuardarIni ficIni, "General", sTmp, sUserPath
    GuardarIni ficIni, "General", "Usuario", sUsuario
    
    numBases = Combo1.ListCount
    GuardarIni ficIni, "General", "NumeroBases", CStr(numBases)
    'Guardar los nombres
    For i = 1 To numBases
        sTmp = "Base" & Format$(i, "00")
        sBase = Combo1.List(i - 1)
        GuardarIni ficIni, "General", sTmp, sBase
    Next
    
    'Asignar el nombre de la base a la variable global
    sBase = sUserBase
    gsNotas.Show
    'Descargar este form
    Unload Me
End Sub

La línea de botones desde Nuevo a Pegar son cmdAccion(x) y los índices de 0-Nuevo hasta 2-Borrar El botón Salir sigue igual, pero hay que incluirlo en el Picture1, que tiene la propiedad Align Top, sin bordes, Flat y con fondo gris claro. Las etiquetas: Label1(x) y los índices desde el 0-Fecha a 5-Fecha Término. Las cajas de Texto: Text1(x) Asunto (2) y Descripción (3) son Multiline. Terminado es: Check1

'---------------------------------------------------------------
'Form para la entrada de datos de las Tareas        ( 7/Mar/97)
'
'Primera tentativa: 7/Mar/97
'
'código de ejemplo realizado por Guillermo Som
'---------------------------------------------------------------
Option Explicit

Dim YaEstoyAqui As Boolean          'Para el Text2
'constantes para los botones de acción
Const CMD_NUEVO = 0
Const CMD_ACTUALIZAR = 1
Const CMD_BORRAR = 2
'Constantes para las acciones de actualización, etc del Data
Const EM_NOTHING = 0
Const EM_EDIT = 1
Const EM_ADDNEW = 2
'Constantes para el campo
Const cID = 0
Const cFecha = 1
Const cAsunto = 2
Const cDescripcion = 3
Const cFechaInicio = 4
Const cFechaTermino = 5
Const cTerminada = 6


Private Sub Check1_Click()
    'Actualizar el Text asociado
    Text1(cTerminada) = Check1.Value
End Sub


Private Sub cmdAccion_Click(Index As Integer)

    If Index = CMD_NUEVO Then           'Nuevo registro
        YaEstoyAqui = True
        Data1.Recordset.AddNew
        Data1.Enabled = False
        YaEstoyAqui = False
        Text1(1).SetFocus
    ElseIf Index = CMD_ACTUALIZAR Then
        'Guardar el contenido de cada uno de los campos
        If Data1.EditMode = EM_ADDNEW Then
            Data1.Recordset.Update
        Else
            Data1.Recordset.Edit
            Data1.Recordset.Update
            If Data1.EditMode = 0 Then
                '
            Else
                Data1.UpdateControls
            End If
        End If
        Data1.Enabled = True
        Data1.Refresh
        Data1.Recordset.MoveLast
        Text1(1).SetFocus
    ElseIf Index = CMD_BORRAR Then      'Borrar registro
        If MsgBox("¿Seguro que quieres borrar este registro?", 4 + 32 + 256) = 6 Then
            Data1.Recordset.Delete
            Data1.Refresh
            If Not Data1.Recordset.EOF Then
                Data1.Recordset.MoveLast
            Else
                Data1.Caption = "No hay registros"
            End If
        End If
    End If
End Sub


Private Sub cmdSalir_Click()
    Unload Me
    End
End Sub


Private Sub Data1_Reposition()
    Dim sTmp As String
    
    On Local Error Resume Next

    If Not Data1.Recordset.EOF Then
        'Esta rutina se ejecuta cuando un registro es el
        'registro actual, (cada vez que se actualiza)
        If Not IsNull(Data1.Recordset!ID) Then _
            sTmp = Data1.Recordset!ID
        
        If Not IsNull(Data1.Recordset!Fecha) Then _
            sTmp = sTmp & ", " & Data1.Recordset!Fecha
            
        If Not IsNull(Data1.Recordset!Asunto) Then _
            sTmp = sTmp & ", " & Data1.Recordset!Asunto
            
        If Len(sTmp) Then
            Data1.Caption = sTmp
        Else
            Data1.Caption = " Registro en blanco."
        End If
        If Not YaEstoyAqui Then
            If Not IsNull(Data1.Recordset!ID) Then
                Text2.Text = Data1.Recordset!ID
                YaEstoyAqui = True
                If Val(Data1.Recordset.Terminada) Then
                    Check1.Value = 1
                Else
                    Check1.Value = 0
                End If
                YaEstoyAqui = False
            End If
        End If
    Else
        Data1.Caption = "No hay registros."
        Text2.Text = Null
    End If
    Err = 0
    On Local Error GoTo 0
End Sub


Private Sub Form_Load()
    Show
    'Cargar la tabla
    CargarTabla
End Sub


Private Sub Form_Unload(Cancel As Integer)
    Set gsNotas = Nothing
End Sub


Private Sub Text2_GotFocus()
    Text2.SelStart = 0
    Text2.SelLength = Len(Text2.Text)
End Sub


Private Sub Text2_KeyPress(KeyAscii As Integer)
    Dim TxtID As Long

    On Local Error Resume Next

    If KeyAscii = 13 Then
        KeyAscii = 0
        If Not IsNull(Text2.Text) Then
            'Buscar ese ID.
            If Not YaEstoyAqui Then
                'Para poder modificar este campo...
                TxtID = Val(Text2.Text)
                Data1.Recordset.FindFirst "ID = " & CStr(TxtID)
                Text2.Text = Data1.Recordset!ID
            End If
        End If
    End If
End Sub

Option Compare Text