El código de gsNotas versión 3.0

Una utilidad para guardar anotaciones en una base de datos usando ADO

Publicado el 08/Oct/2001
Actualizado el 11/Nov/2001


El código de gsNotas v3.0 en formato zip: gsNotasv3.zip 166 KB

 

 

 

 


 

Los formularios:

El código del formulario de entrada, selección de la base de datos (frmEntrada)


'------------------------------------------------------------------------------
' Entrada.frm                                                       (24/Feb/97)
'
' Formulario para seleccionar el usuario y la base de datos
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit
Option Compare Text

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(sTmp, 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
        Exit Sub
        '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$(gCD.LeerIni(sFicIni, "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
        If MsgBox("Atención la base especificada no tiene extensión MDB" & vbCrLf & "¿Intentar cargarla?", vbYesNo + vbInformation, cMsg) = vbNo Then
            ' Posicionarse en el Combo1
            Combo1.Text = sUserBase & ".mdb"
            Combo1.SetFocus
            Exit Sub
        End If
    End If
        
    ' Comprobar si existe "físicamente" 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
            Err = 0
        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
    gCD.GuardarIni sFicIni, "General", sTmp, sUserPath
    gCD.GuardarIni sFicIni, "General", "Usuario", sUsuario
    
    numBases = Combo1.ListCount
    gCD.GuardarIni sFicIni, "General", "NumeroBases", CStr(numBases)
    ' Guardar los nombres
    For i = 1 To numBases
        sTmp = "Base" & Format$(i, "00")
        sBase = Combo1.List(i - 1)
        gCD.GuardarIni sFicIni, "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

Private Sub cmdCancelar_Click()
    'Terminar el programa!!!
    Unload Me
    End
End Sub

Private Sub cmdExaminar_Click()
    ' Abrir el control de diálogos comunes y "localizar"
    ' los archivos con extensión MDB
    ' Seleccionar el fichero en el que se empezará la Busqueda
    '
    ' Referencia a la clase de diálogos comunes                     ( 1/Sep/97)
    ' Sólo se usa en este procedimiento                             (07/Ago/00)
    'Dim CommonDialog1 As cgsFileOp
    
    On Local Error Resume Next
    
    'Set CommonDialog1 = New cgsFileOp
    
    With gCD 'CommonDialog1
        .hWnd = hWnd
        .DialogTitle = "Seleccionar Base de Datos"
        .Filter = "Bases (*.mdb)|*.mdb|Todos los archivos (*.*)|*.*"
        .FilterIndex = 1
        .CancelError = True
        .ShowOpen
        If Err = 0 Then
            Combo1.Text = .FileName
        End If
    End With
    
    'Set CommonDialog1 = Nothing
    
    Err = 0
End Sub

Private Sub Form_Load()
    Dim numBases As Long
    Dim sBase As String
    Dim sNum As String
    Dim i As Long
    Dim sPath As String
    Dim sUser As String
    '
    ' Crear el objeto                                               (01/Oct/01)
    Set gCD = New cgsFileOp
    '
    ' Archivo de configuración en el directorio de la aplicación
    sFicIni = gCD.AppPath(False) & "\gsNotas.ini"
    '
    Combo1.Text = ""
    ' Nombre del último usuario
    Text1 = gCD.LeerIni(sFicIni, "General", "Usuario", "")
    sUser = Text1
    ' Leer el número de bases creadas
    numBases = Val(gCD.LeerIni(sFicIni, "General", "NumeroBases"))
    ' Comprobar y leer los nombres
    For i = 1 To numBases
        ' Si queremos usar más de 99 nombres, añade un cero más
        sNum = "Base" & Format$(i, "00")
        sBase = Trim$(gCD.LeerIni(sFicIni, "General", sNum))
        If Len(sBase) Then
            sBase = gCD.NameFromFileName(sBase)
            sPath = Trim$(gCD.LeerIni(sFicIni, "General", sUser & Format$(i, "00")))
            ' Añadir al combo, si no es una cadena vacía
            Combo1.AddItem sPath & "\" & sBase
        End If
    Next
    If Combo1.ListCount Then
        Combo1.ListIndex = 0
    End If
    '
    If gNoCargar = False Then
        ' Si hay datos en el Combo, seleccionar el primero
        If Combo1.ListCount Then
            Combo1.ListIndex = 0
            ' Aquí pondremos las opciones de entrada "personalizada"
            ' es decir sólo si hay bases asignadas.
            If Len(Trim$(Command$)) Then
                ProcesarLineaComandos
            End If
        End If
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Liberar memoria
    Set frmEntrada = Nothing
End Sub

Private Sub CrearBase(ByRef sBase As String)
    ' Crear la base de datos indicada
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim idx As ADOX.Index
    Dim col As ADOX.Column
    Dim i As Long
    '
    ' Se creará siempre compatible con Access 2000,                 (08/Oct/01)
    ' ya que el otro provider no acepta campos autonuméricos, etc. ¿¿¿???
'    i = MsgBox("¿Quieres crear la base de datos?" & vbCrLf & _
'        "Nota: Se creará con formato compatible con Access 2000 (Microsoft.Jet.OLEDB.4.0)" & vbCrLf & _
'        "Pulsa en Cancelar para terminar el programa.", vbQuestion + vbOKCancel, "Crear Base de datos")
'    If i = vbCancel Then
'        Unload Me
'        Exit Sub
'    End If
    '
    DataProvider = "Microsoft.Jet.OLEDB.4.0"
    '
    Set cat = New ADOX.Catalog
    ' Crear la base de datos
    cat.Create "Provider=" & DataProvider & ";" & _
               "Data Source=" & sBase & ";"
    '
    Set tbl = New ADOX.Table
    Set idx = New ADOX.Index
    '
    sTabla = "Tareas"
    '
    ' Crear la nueva tabla
    With tbl
        .Name = sTabla
        ' Crear los campos y añadirlos a la tabla.
        ' Es un "rollo" el que los campos se clasifiquen, ya que
        ' en el código del programa está pensado que siga una secuencia:
        '
        ' Esto hay que hacerlo antes de añadir la tabla a la colección de tablas
        '
        '.Columns.Append "c1ID", adInteger
        Set col = New ADOX.Column
        With col
            .Name = "c1ID"
            .Type = adInteger
            Set .ParentCatalog = cat
            .Properties("AutoIncrement") = True
        End With
        .Columns.Append col
        '
        .Columns.Append "c2Fecha", adDate
        '
        ' Para Access 2000
        .Columns.Append "c3Asunto", adVarWChar, 255
        .Columns.Append "c4Descripcion", adLongVarWChar ' Una cadena larga, (Memo)
        .Columns.Append "c5FechaInicio", adDate
        .Columns.Append "c6FechaTermino", adDate
        .Columns.Append "c7Terminada", adInteger
        .Columns.Append "c8Apartado", adVarWChar, 25
        '
        .Columns("c2Fecha").Attributes = adColNullable      ' Permite contener nulos
        .Columns("c3Asunto").Attributes = adColNullable
        .Columns("c4Descripcion").Attributes = adColNullable
        .Columns("c5FechaInicio").Attributes = adColNullable
        .Columns("c6FechaTermino").Attributes = adColNullable
        .Columns("c7Terminada").Attributes = adColNullable
        .Columns("c8Apartado").Attributes = adColNullable
    End With
    With idx
        .Name = "Indice" & sTabla
        .Columns.Append "c1ID", adInteger
    End With
    tbl.Indexes.Append idx
    '
    ' Añadir la nueva tabla a la base de datos
    cat.Tables.Append tbl
    '
    Set idx = Nothing
    Set tbl = Nothing
    Set cat = Nothing
    '
    MsgBox "Nueva base de datos " & sBase & " creada.", vbInformation
End Sub

Private Sub ProcesarLineaComandos()
    'La forma de los parámetros será:
    '/U nombre_usuario /B nombre_base
    Dim sTmp As String
    Dim sUser As String
    Dim sBase As String
    Dim i As Long
    
    Show
    DoEvents
    
    sTmp = Trim$(Command$)
    
    'tomar el nombre del usuario
    i = InStr(sTmp, "/U")
    If i Then
        sUser = Mid$(sTmp, i + 2)
        i = InStr(sUser, "/")
        If i Then
            sUser = Left$(sUser, i - 1)
        End If
        sUser = Trim$(sUser)
        Text1 = sUser
    End If
    'Ahora la base:
    i = InStr(sTmp, "/B")
    If i Then
        sBase = Mid$(sTmp, i + 2)
        i = InStr(sBase, "/")
        If i Then
            sBase = Left$(sBase, i - 1)
        End If
        sBase = Trim$(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, "Cargando automáticamente"
            Unload Me
            End
        End If
        Combo1.Text = sBase
    End If
    'Hacer como si se hubiese pulsado en aceptar
    cmdAceptar_Click
End Sub

El código del formulario principal (gsNotas.frm)


'------------------------------------------------------------------------------
' Form para la entrada de datos de las Tareas                       ( 7/Mar/97)
'
' Primera tentativa:      7/Mar/97
'
' Revisiones:
'
'   21/May/97   Arreglo en los datos mostrados en la consulta
'    5/Jul/97   Buscar usando orden SQL
'    2/Ago/97   Nuevas opciones Avanzadas: Copiar y Nuevo (para usar con los mails)
'               Se guardan los últimos items de la lista de buscar
'
'    3/Sep/97   Varios añadidos y mejoras:
'               Editar el texto en form aparte, imprimirlo, etc.
'    6/Sep/97   En buscar, poder hacerlo de atrás a adelante y
'               palabra completa (===por hacer)
'   16/Sep/97   Mejoras al usar F4 y quitar los intros al principio
'               cuando se usa xxxAvan
'               Añadido Bookmarks, para ir rápidamente a los registros
'   17/Sep/97   Algunas mejoras en los bookmarks y quitado el From: guille...
'    5/Oct/97   Añado nueva opción al menú de Registros para ampliar campo
'   13/Nov/97   Usando RichTextBox (al final lo quité)
'   22/Feb/98   Arreglo del "bug" de los dos puntos...
'   24/Mar/98   Vuelvo a usar el RichTextBox
'   29/Mar/98   Arreglo el error 3426 cuando añadía un nuevo dato,
'               (aunque ese error no ocurría siempre, por suerte)
'               Sigue ocurriendo... la verdad es que no se dónde...
'   31/Mar/98   He hecho varias pruebas más... ahora parece que va bien
'    2/Abr/98   Le añado al combo de búsqueda el que muestre las
'               palabras conforme se va escribiendo
'   19/Ago/99   Modificaciones en el formulario de buscar (en IniciarCombo)
'
' Nueva versión (2.00.xxxx)
'    6/Ago/2000 Panel de vistas y botones configurables
'   09/Ago/2000 Ya está operativa la configuración de los botones
'   10/Ago/2000 Algunos arreglillos varios
'   10/Nov/2000 Usando DAO 3.6 para poder usar bases de Access 2000
'
' Nueva versión (3.00.xxxx) usando ADO
'   01/Oct/2001 Actualizado para usar ADO y algunos otros cambios
'   08/Oct/2001 Arreglo de algunos bugs
'   14/Oct/2001 Arreglado un problema de tabulación en gsQBE
'
' ©Guillermo 'guille' Som, 1997-2001
' /U Guillermo /BNotasGuille.mdb
'------------------------------------------------------------------------------
Option Explicit
Option Compare Text

' Valores para usar con ADO                                         (01/Oct/01)
Private RsBuscar As ADODB.Recordset         ' para la rutina de búsqueda
Private WithEvents Data1 As ADODB.Recordset ' Sustituye al control Data
'
'
Dim NumApartadosAnt As Long                 ' Los apartados antes de crearlos
'
Dim buscAtras As Boolean                    ' Dirección de búsqueda
Dim buscCompleta As Boolean                 ' Palabra completa

'Dim RsBuscar As Recordset                   ' para la rutina de búsqueda ( 5/Jul/97)
'Dim Db As Database                          ' Ahora se mantiene abierta

Dim NoActualizar As Boolean                 ' para controlar el Reposition

Dim iH As Integer                           ' Tamaño mínimo de la ventana
Dim iW As Integer

Dim ControlActual As Integer                ' Para saber cual es el text que está activo
Dim YaEstoyAqui As Boolean                  ' Para el Text2
' constantes para los botones de acción
' Según el ToolBar
Const CMD_NuevoAvan = 2
Const CMD_Nuevo = 3
Const CMD_Actualizar = 4
Const CMD_Borrar = 5
Const CMD_PegarAvan = 7
Const CMD_Buscar = 9
Const CMD_BuscarSiguiente = 10
Const CMD_BookmarkLista = 12
Const CMD_BookmarkNuevo = 13
Const CMD_BookmarkAnterior = 14
Const CMD_BookmarkSiguiente = 15
Const CMD_Consulta = 17
Const CMD_Clasificar = 19
Const CMD_Compactar = 21
Const CMD_Configurar = 23
Const CMD_Acerca = 25
Const CMD_Salir = 27
'
Const CMD_Reemplazar = 105
'
' Las variables de edición están declaradas globalmente en gsDBR.bas
' para usar los procedimientos genéricos de búsqueda     (31/Ago/97)
'
'Const CMD_BuscarActual = 101
'Const CMD_BuscarSigActual = 102
'Const CMD_ReemplazarActual = 103
'Const CMD_SeleccionarTodo = 104
'
'Constantes para el menú de Edición
'Const mEdDeshacer = 0
'Const mEdCortar = 1
'Const mEdCopiar = 2
'Const mEdPegar = 3
'Const mEdSep1 = 4
'Const mEdBuscarActual = 5
'Const mEdBuscarSigActual = 6
'Const mEdReemplazarActual = 7
'Const mEdSep2 = 8
'Const mEdSeleccionarTodo = 9
'
' 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
Const cApartado = 7

Private Sub CompactarBase()
    ' Compactar una base de datos con ADO
    Dim sDBTmp As String
    Dim je As JRO.JetEngine
    Dim i As Long
    '
    On Error GoTo ErrCompactar
    '
    Set je = New JRO.JetEngine
    '
    ' deshabilitar los botones
    With Toolbar1
        For i = 1 To CMD_Acerca - 1
            .Buttons(i).Enabled = False
        Next
    End With
    '
    ' Cerrar la conexión y recordset actual,                        (08/Oct/01)
    ' ya que tiene que estar abierto en modo exclusivo
    '
    Data1.Close
    Set Data1 = Nothing
    Cnn.Close
    Set Cnn = Nothing
    '
    ' Crear un nombre "medio" aleatorio
    sDBTmp = "DBT_" & Format$(Minute(Now), "00") & Format$(Second(Now), "00") & ".mdb"
    ' Asegurarnos de que no existe una base con el nombre temporal
    If Len(Dir$(sDBTmp)) Then
        Kill sDBTmp
    End If
    '
    LblStatus(1).Tag = LblStatus(1).Caption
    LblStatus(1).Caption = " Compactando la base de datos..."
    LblStatus(1).Refresh
    '
    ' Compactar la base de datos
    je.CompactDatabase "Data Source=" & sBase & ";", _
                       "Data Source=" & sDBTmp & ";"
    '
    ' Eliminar la base de datos original
    Kill sBase
    '
    ' Renombrar la base temporal con el original
    Name sDBTmp As sBase
    '
    LblStatus(1).Caption = " Base de datos compactada."
    LblStatus(1).Refresh
    '
CompactarSalir:
    ' habilitar los botones
    With Toolbar1
        For i = 1 To CMD_Acerca - 1
            .Buttons(i).Enabled = True
        Next
    End With
    CargarTabla
    '
    LblStatus(1).Caption = LblStatus(1).Tag
    LblStatus(1).Refresh
    '
    Exit Sub
    '
ErrCompactar:
    ' Mostrar el mensaje de error
    MsgBox "Error al compactar la base de datos:" & vbCrLf & _
            Err.Number & " " & Err.Description, _
            vbExclamation, "Error al compactar la base de datos"
    Err.Clear
    LblStatus(1).Caption = " *** Error al compactar la base de datos ***"
    LblStatus(1).Refresh
    '
    Resume CompactarSalir
End Sub

Private Sub CargarTabla()
    Dim Rs As Recordset
    Dim Fd As Field
    Dim i As Long
    Dim j As Long
    Dim HayDatos As Boolean
    
    sTabla = "Tareas"
    '
    ' Para que no se trate de ahcer nada hasta que se carguen los datos
    NoActualizar = True
    '
    ' Para usar con ADO                                             (01/Oct/01)
    CrearConexion Cnn, True
    ' Asignar el recordset Data1
    Set Data1 = New ADODB.Recordset
    Data1.Open "select * from " & sTabla & " order by " & sClasif, Cnn, adOpenDynamic, adLockOptimistic
    '
    ' Crear el recordset para leer la estructura de la tabla
    Set Rs = New ADODB.Recordset
    Rs.Open sTabla, Cnn, adOpenDynamic, adLockOptimistic, adCmdTable
    '
    ' Número de campos, empezando por cero
    j = Rs.Fields.Count - 1
    NumCampos = j
    
    ' Asegurarse que los texts no están asociados
    For i = 0 To j - 1
        With Text1(i)
            .DataField = ""
            .Text = ""
        End With
    Next
    RichTextBox1.Text = ""
    RichTextBox1.TextRTF = ""
    '
    '-(10/Abr/97)- Asignamos el tamaño del array de campos
    ReDim Campos(j)
    
    i = -1
    For Each Fd In Rs.Fields
        i = i + 1
        '-(10/Abr/97)- Asignamos los datos de los campos
        With Campos(i)
            .Nombre = Fd.Name
            .Tamaño = Fd.DefinedSize  ' Size
            .Tipo = Fd.Type
        End With
        
        If InStr(Fd.Name, "Descripcion") Then
            'Set RichTextBox1.DataSource = Data1
            RichTextBox1.DataField = Fd.Name
            ' Asignarlo también en el Text(i) por si se usa en bucles
            Text1(i).DataField = Fd.Name
        Else
            With Text1(i)
                ' El DataSource da error en tiempo de ejecución
                ' así que debe estar asignado en las propiedades del form
                'Set .DataSource = Data1
                .DataField = Fd.Name
                ' Asignar el tamaño máximo de cada campo
                Select Case Fd.Type
                Case dbMemo
                    .MaxLength = 64000
                Case dbDate
                    .MaxLength = 10
                Case dbText
                    .MaxLength = Fd.DefinedSize
                Case Else
                    .MaxLength = 15
                End Select
            End With
        End If
    Next
    Rs.Close
    Set Fd = Nothing
    Set Rs = Nothing
    '
    HayDatos = True
    '
    If HayDatos Then
        If Not Data1.EOF Then
            HayDatos = True
        Else
            HayDatos = False
        End If
    End If
    '
    If HayDatos Then
        Data1.MoveLast
    Else
        ' No hay datos en la base aún    (16/Sep/95)
        MsgBox "Antes de empezar a introducir datos," & vbCrLf & "debes seleccionar NUEVO.", 48
    End If
    '
    NoActualizar = False
    
    cmdView(0).BackColor = vbInactiveCaptionText
    '
    Err = 0
    On Error GoTo 0
    '
    LblStatus(1) = "User: " & sUsuario & ", Tabla: " & sTabla & ", Base: " & sBase & ", (" & DataProvider & ")"
End Sub

Private Sub cboApartados_Change()
    ' Asignar el apartado al que corresponde esta anotación         (07/Ago/00)
'    Text1(cApartado) = cboApartados.Text
End Sub

Private Sub cboApartados_Click()
    ' Asignar el apartado al que corresponde esta anotación         (07/Ago/00)
'    Text1(cApartado) = cboApartados.Text
End Sub

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

Private Sub Check1_GotFocus()
    ControlActual = 0
End Sub

Private Sub cmdAccion_Click(Index As Integer)
    Static esNuevo As Boolean
    Dim i As Long
    Static sBuscar As String
    Dim sTmp As String
    Dim BusquedaNoHallada As Boolean
    Dim j As Long
    Dim sBookmark As String
    Dim qID As Long
    
    LblStatus(1).Tag = LblStatus(1).Caption
    
    Select Case Index
    Case CMD_Nuevo              ' Nuevo registro
        If Not esNuevo Then
            ' Probar a ver si así se evita el error      (30/Mar/98)
            AñadirRegistro
            '
            NoActualizar = False
            esNuevo = False
            
            On Local Error Resume Next
            Data1.MoveLast
            Err = 0
            On Local Error GoTo 0
            '******************************
            '     NO ACTUALIZAR AQUÍ
            'DoEvents
            'cmdAccion_Click CMD_Actualizar
            '******************************
            'Text1(cAsunto).SetFocus
            Text1(cFecha).SetFocus
        End If
    Case CMD_NuevoAvan              ' Nuevo, pegar mensaje... ( 2/Ago/97)
        cmdAccion_Click CMD_Nuevo
        PegarMensaje
        ' Dejar esta línea, aunque esté en PegarMensaje  (16/Sep/97)
        cmdAccion_Click CMD_Actualizar
        Exit Sub
    Case CMD_Actualizar
        esNuevo = False
        ' Guardar el contenido de cada uno de los campos
        'On Local Error Resume Next
        ActualizarRegistro
        If ControlActual = 0 Then
            Text1(1).SetFocus
        End If
    Case CMD_PegarAvan
        PegarMensaje
        Exit Sub
    Case CMD_Borrar             ' Borrar registro
        If MsgBox("¿Seguro que quieres borrar este registro?", 4 + 32 + 256) = 6 Then
            On Local Error Resume Next
            With Data1
                NoActualizar = True
                fBookmarks.Borrar !c1ID
                .Delete
                NoActualizar = False
                If Not .EOF Then
                    .MoveLast
                Else
                    Data1Caption = "No hay registros"
                End If
                If Err Then
                    Err = 0
                    Data1Caption = "No hay registros"
                End If
            End With
            On Local Error GoTo 0
        End If
    Case CMD_Buscar             ' Buscar registros
        ' Si no estamos en un Text de búsqueda, salir
        If ControlActual = 0 Then Exit Sub
        
        If ControlActual = cDescripcion Then
            With RichTextBox1
                If .SelLength > 0 Then
                    sBuscar = "%" & Trim$(.SelText)
                Else
                    sBuscar = "%"
                End If
            End With
        Else
            ' Si hay texto seleccionado...
            With Text1(ControlActual)
                If .SelLength > 0 Then
                    sBuscar = "%" & Trim$(.SelText)
                Else
                    sBuscar = "%"
                End If
            End With
        End If
        ' Para "personalizar" la sección de búsqueda...
        gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
        ' Para que se marque la búsqueda hacia atrás.
        iFFAtras = True
        If gsBuscar(sBuscar, cFFAc_Buscar + cFFAc_Atras, "Buscar datos") > cFFAc_IDLE Then
            sBuscar = Trim$(sBuscar)
            ' Cambiar los comodines antiguos por los nuevos         (01/Oct/01)
            sBuscar = Replace(sBuscar, "*", "%")
            sBuscar = Replace(sBuscar, "?", "_")
            '
            If Len(sBuscar) Then
                buscAtras = iFFAtras
                LblStatus(1) = "Buscando " & sBuscar & "..."
                DoEvents
                ' Usar una rutina del tipo consulta (SQL)
                qID = BuscarEnBase(Campos(ControlActual).Nombre & " LIKE '" & sBuscar & "%'")
                If qID Then
                    Data1.Find "c1ID = " & CStr(qID), , adSearchForward, 1
                    If Data1.EOF Then
                        qID = 0&
                    End If
                End If
                If qID = 0& Then
                    Beep
                    MsgBox "No se ha hallado el dato buscado en el campo: " & Campos(ControlActual).Nombre, vbOK + vbInformation, "Buscar"
                    If ControlActual = cDescripcion Then
                        RichTextBox1.SetFocus
                    Else
                        Text1(ControlActual).SetFocus
                    End If
                    Data1.MoveLast
                Else
                    sTmp = sBuscar
                    If Left(sTmp, 1) = "%" Then
                        sTmp = Mid$(sTmp, 2)
                    End If
                    If ControlActual = cDescripcion Then
                        With RichTextBox1
                            i = InStr(.Text, sTmp)
                            .SelStart = i - 1
                            .SelLength = Len(sTmp)
                            ' posicionarse en ese control
                            .SetFocus
                        End With
                    Else
                        ' Seleccionar el texto hallado
                        With Text1(ControlActual)
                            i = InStr(.Text, sTmp)
                            .SelStart = i - 1
                            .SelLength = Len(sTmp)
                            ' posicionarse en ese control
                            .SetFocus
                        End With
                    End If
                End If
            End If
        End If
    Case CMD_BuscarSiguiente
        If Len(sBuscar) = 0 Then
            cmdAccion_Click CMD_Buscar
        Else
            LblStatus(1) = "Buscando " & sBuscar & "..."
            DoEvents
            qID = BuscarEnBase("")
            If qID Then
                Data1.Find "c1ID = " & CStr(qID), , adSearchForward, 1
                If Data1.EOF Then
                    qID = 0&
                End If
            End If
            If qID = 0& Then
                Beep
                MsgBox "No se han hallado más coincidencias del dato buscado en el campo: " & Campos(ControlActual).Nombre, vbOK + vbInformation, "Buscar Siguiente"
                If ControlActual = cDescripcion Then
                    RichTextBox1.SetFocus
                Else
                    Text1(ControlActual).SetFocus
                End If
                Data1.MoveLast
            Else
                sTmp = sBuscar
                If Left(sTmp, 1) = "*" Then
                    sTmp = Mid$(sTmp, 2)
                End If
                If ControlActual = cDescripcion Then
                    With RichTextBox1
                        i = InStr(.Text, sTmp)
                        If i Then
                            .SelStart = i - 1
                            .SelLength = Len(sTmp)
                        End If
                        ' posicionarse en ese control
                        .SetFocus
                    End With
                Else
                    ' Seleccionar el texto hallado
                    With Text1(ControlActual)
                        i = InStr(.Text, sTmp)
                        If i Then
                            .SelStart = i - 1
                            .SelLength = Len(sTmp)
                        End If
                        ' posicionarse en ese control
                        .SetFocus
                    End With
                End If
            End If
        End If
    Case CMD_Reemplazar
        ' Si no estamos en un Text de búsqueda, salir
        If ControlActual = 0 Then Exit Sub
        If ControlActual = cDescripcion Then
            With RichTextBox1
                If .SelLength > 0 Then
                    sBuscar = "%" & Trim$(.SelText)
                End If
            End With
        Else
            ' Si hay texto seleccionado...
            With Text1(ControlActual)
                If .SelLength > 0 Then
                    sBuscar = "%" & Trim$(.SelText)
                End If
            End With
        End If
        sFFBuscar = sBuscar
        sFFPoner = ""
        ' Personalizar las secciones de buscar/reemplazar
        gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
        gsDBR.Combo1(1).Tag = "Reemplazar_" & sUsuario
        iFFAccion = gsReemplazar(sFFBuscar, sFFPoner)
        If iFFAccion <> cFFAc_Cancelar Then
            MousePointer = vbHourglass
            DoEvents
            sBuscar = Trim$(sFFBuscar)
            ' Por si se indican comodines NO compatibles            (01/Oct/01)
            sBuscar = Replace(sBuscar, "*", "%")
            sBuscar = Replace(sBuscar, "?", "_")
            sFFBuscar = sBuscar
            '
            ' Quitar de los caracteres de asteríscos
            Do While InStr(sFFBuscar, "%")
                i = InStr(sFFBuscar, "%")
                sFFBuscar = Left$(sFFBuscar, i - 1) & Mid$(sFFBuscar, i + 1)
            Loop
            If Len(sFFBuscar) <> 0 And Len(sFFPoner) <> 0 Then
                If iFFAccion = cFFAc_Reemplazar Or iFFAccion = cFFAc_ReemplazarTodo Then
                    LblStatus(1) = "Buscando " & sBuscar & "..."
                    DoEvents
                    qID = BuscarEnBase(Campos(ControlActual).Nombre & " LIKE '" & sBuscar & "%'")
                    If qID Then
                        Data1.Find "c1ID = " & CStr(qID), , adSearchForward, 1
                        If Data1.EOF Then
                            qID = 0&
                        End If
                    End If
                    If qID = 0& Then
                        Beep
                        MsgBox "No se ha hallado el dato buscado en el campo: " & Campos(ControlActual).Nombre, vbOK + vbInformation, "Reemplazar"
                        If ControlActual = cDescripcion Then
                            RichTextBox1.SetFocus
                        Else
                            Text1(ControlActual).SetFocus
                        End If
                        BusquedaNoHallada = True
                        Data1.MoveLast
                    End If
                    Do Until BusquedaNoHallada
                        If ControlActual = cDescripcion Then
                            sTmp = RichTextBox1.Text
                        Else
                            sTmp = Text1(ControlActual).Text
                        End If
                        ' cambiar... (comprobar si es palabra completa)
                        If Left$(sBuscar, 1) = "%" Then
                            i = InStr(sTmp, sFFBuscar)
                        Else
                            If Left$(sTmp, Len(sFFBuscar)) = sFFBuscar Then
                                i = 1
                            Else
                                i = 0
                            End If
                        End If
                        If i Then
                            sTmp = Left$(sTmp, i - 1) & sFFPoner & Mid$(sTmp, i + Len(sFFBuscar))
                            If ControlActual = cDescripcion Then
                                RichTextBox1.Text = sTmp
                            Else
                                Text1(ControlActual).Text = sTmp
                            End If
                        End If
                        If iFFAccion = cFFAc_Reemplazar Then Exit Do
                        ' Cambiar todas las coincidencias en el mísmo text
                        j = 1
                        Do
                            If Left$(sBuscar, 1) = "%" Then
                                i = InStr(j, sTmp, sFFBuscar)
                            Else
                                If Left$(sTmp, Len(sFFBuscar)) = sFFBuscar Then
                                    i = 1
                                Else
                                    i = 0
                                End If
                            End If
                            If i Then
                                j = i + 1
                                sTmp = Left$(sTmp, i - 1) & sFFPoner & Mid$(sTmp, i + Len(sFFBuscar))
                                If ControlActual = cDescripcion Then
                                    RichTextBox1.Text = sTmp
                                Else
                                    Text1(ControlActual).Text = sTmp
                                End If
                            End If
                        Loop While i
                        DoEvents
                        qID = BuscarEnBase("")
                        If qID Then
                            Data1.Find "c1ID = " & CStr(qID), , adSearchForward, 1
                            If Data1.EOF Then
                                BusquedaNoHallada = True
                                Data1.MoveLast
                            Else
                                BusquedaNoHallada = False
                            End If
                        Else
                            BusquedaNoHallada = True
                        End If
                    Loop
                End If
            End If
            MousePointer = vbDefault
            DoEvents
        End If
    End Select
    
    LblStatus(1) = LblStatus(1).Tag
End Sub

Private Sub cmdMover_Click(Index As Integer)
    ' Moverse por el recordset
    On Error Resume Next
    Err = 0
    '
    ' Antes de mover el registro, actualizar los datos que haya
    ' NOTA: ESTO A LA LARGA DA PROBLEMAS...
    '       COMO MUCHO, AVISAR DE QUE LOS DATOS HAN CAMBIADO
'    'ActualizarRegistro
    '
    With Data1
        Select Case Index
        Case 0  ' Primero
            .MoveFirst
        Case 1  ' Anterior
            .MovePrevious
        Case 2  ' Siguiente
            .MoveNext
        Case 3  ' Último
            .MoveLast
        End Select
        '
        ' Si estamos fuera de los límites...
        If .BOF Then
            .MoveFirst
        ElseIf .EOF Then
            .MoveLast
        End If
    End With
    '
    If Text1(cAsunto).Visible Then
        Text1(cAsunto).SetFocus
    End If
    '
    Err = 0
End Sub

Private Sub cmdView_Click(Index As Integer)
    ' Al hacer click en estos botones,                              (07/Ago/00)
    ' mostrar los mensajes asociados
    '
    Dim i As Long
    
    On Local Error Resume Next
    
    For i = 0 To NumApartados
        cmdView(i).BackColor = vbButtonFace
    Next
    
    Err = 0
    '
    NoActualizar = True
    '
    Data1.Close
    Set Data1 = Nothing
    Set Data1 = New ADODB.Recordset
    If Index = 0 Then
        ' Todos los datos
        'Data1.RecordSource = "select * from " & sTabla & " order by " & sClasif
        Data1.Open "select * from " & sTabla & " order by " & sClasif, Cnn, adOpenDynamic, adLockOptimistic
    Else
        ' Sólo los del Apartado indicado
        'Data1.RecordSource = "select * from " & sTabla & " WHERE Apartado = '" & cmdView(Index).Caption & "' order by " & sClasif
        Data1.Open "select * from " & sTabla & " WHERE Apartado = '" & cmdView(Index).Caption & "' order by " & sClasif, Cnn, adOpenDynamic, adLockOptimistic
    End If
    '
    ' Da error 13-Type Mismatch si no hay registros
    'Data1.Refresh
    Data1.MoveLast
    '
    If Data1.EOF Then
        'Data1.RecordSource = "select * from " & sTabla & " order by " & sClasif
        Data1.Open "select * from " & sTabla & " order by " & sClasif, Cnn, adOpenDynamic, adLockOptimistic
    End If
    '
    NoActualizar = False
    Data1.MoveLast
    '
    cmdView(Index).BackColor = vbGrayText ' vbInactiveCaptionText ' vbButtonShadow
    '
    Err = 0
End Sub

Private Sub Data1_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    Dim sTmp As String
    Dim i As Long
    '
    If NoActualizar Then Exit Sub
    
    On Local Error Resume Next
    
    If Not Data1.EOF Then
        ' Esta rutina se ejecuta cuando un registro es el
        ' registro actual, (cada vez que se actualiza)
        If Not IsNull(Data1!c1ID) Then _
            sTmp = Data1!c1ID
        
        If Not IsNull(Data1!c2Fecha) Then _
            sTmp = sTmp & ", " & Data1!c2Fecha
            
        If Not IsNull(Data1!c3Asunto) Then _
            sTmp = sTmp & ", " & Data1!c3Asunto
            
        If Len(sTmp) Then
            Data1Caption = Replace(sTmp, vbCrLf, " ") ' QuitarCaracter(sTmp, vbCrLf, " ")
        Else
            Data1Caption = " Registro en blanco."
        End If
        If Not YaEstoyAqui Then
            If Not IsNull(Data1!c1ID) Then
                Text2.Text = Data1!c1ID
                If Val(Data1!c7Terminada) Then
                    Check1.Value = 1
                Else
                    Check1.Value = 0
                End If
                cboApartados.Text = Data1!c8Apartado
                If Err Then
                    cboApartados.ListIndex = 0
                End If
                '
                For i = 1 To Text1.Count - 1
                    If i = cDescripcion Then
                        'RichTextBox1.Text = Data1.Fields(RichTextBox1.DataField) & ""
                        RichTextBox1.TextRTF = Data1.Fields(RichTextBox1.DataField) & ""
                    Else
                        Text1(i).Text = Data1.Fields(Text1(i).DataField) & ""
                    End If
                Next
                Err = 0
            End If
        End If
    Else
        Data1Caption = "No hay registros."
        Text2.Text = Null
    End If
    Err = 0
    On Error GoTo 0
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    ' Para los Bookmarks siguiente (Ctrl++) o anterior (Ctrl+-)     (01/Oct/01)
    If (Shift And vbCtrlMask) > 0 Then
        Select Case KeyCode
        Case vbKeyAdd, 187      ' Siguiente Bookmark
            mnuBookmarks_Click 3
        Case vbKeySubtract, 189 ' Bookmark anterior
            mnuBookmarks_Click 2
        End Select
    End If
End Sub

Private Sub Form_Resize()
    Static YaHeEstado As Boolean
    Dim i As Long
    
    ' No hacer nada si se minimiza
    If WindowState = vbMinimized Then Exit Sub
    
    ' No permitir un tamaño menor que el inicial
    If Width < iW Then
        Width = iW
        Exit Sub
    End If
    If Height < iH Then
        Height = iH
        Exit Sub
    End If
    
    ' Si el tamaño de la ventana es menor que el del form,
    ' ajustar el tamaño...                   (11/Oct/98)
    '
    ' Comprobar el ancho
    If Screen.Width < ScaleWidth Then
        Width = iW
        Exit Sub
    End If
    ' Comprobar el alto
    If Screen.Height < ScaleHeight Then
        Height = iH
        Top = 0
        Exit Sub
    End If
    '
    ' Ajustar el tamaño de los contenedores                         (06/Ago/00)
    picView.Move 60, 480, picView.Width, ScaleHeight - 480 - StatusBar1.Height
    picCont.Move picView.Width + 90, 480, ScaleWidth - picView.Width - 120, ScaleHeight - 480 - StatusBar1.Height
    '
    With Text2
        .Left = picCont.ScaleWidth - .Width - 90
        Label1(0).Left = .Left - Label1(0).Width - 30
    End With
    cmdMover(3).Left = Label1(0).Left - 540
    cmdMover(2).Left = cmdMover(3).Left - 330
    With Data1Caption
        .Width = cmdMover(2).Left - .Left - 30
    End With
    'Data1.Width = Label1(0).Left - 180
    
    ' El textBox de Asunto
    With Text1(cAsunto)
        .Width = picCont.ScaleWidth - .Left - 90
    End With
    
'    ' move es más rápido que efectuar los 3 cambios
'    LblStatus(0).Move 30, picCont.ScaleHeight - 225
'    LblStatus(2).Move 30, LblStatus(0).Top - 330
    '
    ' El campo Apartado                                             (06/Ago/00)
    Text1(cApartado).Top = picCont.ScaleHeight - 375
    Label1(cApartado).Top = Text1(cApartado).Top + 30
    cboApartados.Top = Text1(cApartado).Top
    '
    ' El alto del text de la descripción
    With RichTextBox1
        .Width = picCont.ScaleWidth - .Left - 90
        '.Height = LblStatus(0).Top - .Top - 60
'        .Height = picCont.ScaleHeight - .Top - 60
        .Height = Text1(cApartado).Top - .Top - 60
'        LblStatus(1).Top = LblStatus(0).Top
'        LblStatus(1).Width = .Width
    End With
    
    ' Asegurarnos de que no se actualice la primera vez que se carga.
    If YaHeEstado Then
        ' Guardar el tamaño y la posición
        ' Si está maximizado
        If WindowState = vbNormal Then
            gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Left", CStr(Left)
            gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Top", CStr(Top)
            gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Width", CStr(Width)
            gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Height", CStr(Height)
            gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Maximizado", "0"
        Else
            gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Maximizado", "1"
        End If
    End If
    YaHeEstado = True
End Sub

Private Sub LblStatus_Change(Index As Integer)
    StatusBar1.Panels("Status" & CStr(Index)) = LblStatus(Index)
End Sub

Private Sub mnuAcercaDe_Click()
    ' Mostrar la información del programa, versión, etc.
    Dim sMsg As String
    With App
        sMsg = vbCrLf
        sMsg = sMsg & "gsNotas v" & Format$(.Major, "00") & "." & Format$(.Minor, "00") & "." & Format$(.Revision, "0000") & vbCrLf & vbCrLf
        'sMsg = sMsg & .FileDescription & vbCrLf
        sMsg = sMsg & .Comments & vbCrLf & vbCrLf
        sMsg = sMsg & .ProductName & vbCrLf & vbCrLf
        sMsg = sMsg & .LegalCopyright '& vbCrLf & vbCrLf
    End With
    MsgBox sMsg, vbInformation, "Acerca de..."
End Sub

Private Sub mnuBookmark_Click()
    'Comprobar si ya hay elementos en la lista
    Dim bEnabled As Boolean
    Dim i As Integer
    
    i = fBookmarks.Lista.ListCount
    If i < 2 Then
        bEnabled = False
    Else
        bEnabled = True
    End If
    mnuBookmarks(2).Enabled = bEnabled
    mnuBookmarks(3).Enabled = bEnabled
End Sub

Private Sub mnuBookmarks_Click(Index As Integer)
    Dim i As Integer
    Dim lngID As Long
    Dim bEnabled As Boolean
    
    With fBookmarks
        'Acción según la opción seleccionada
        Select Case Index
        Case 0  ' Lista
            .Show vbModal
        Case 1  ' Nuevo
            .Nuevo Data1!c1ID, Data1!c3Asunto
            .ActualizarToolBar
        Case 2, 3   ' Anterior y Siguiente
            If Index = 2 Then
                lngID = .Anterior
            Else
                lngID = .Siguiente
            End If
            ' posicionarse
            If lngID Then
                Data1.Find "c1ID = " & CStr(lngID), , adSearchForward, 1
            End If
        End Select
    End With
End Sub

Private Sub mnuBorrar_Click()
    cmdAccion_Click CMD_Borrar
End Sub

Private Sub mnuClasificar_Click()
    Accion CMD_Clasificar
End Sub

Private Sub mnuCompactar_Click()
    Accion CMD_Compactar
End Sub

Private Sub mnuConsulta_Click()
    gsQBE.Show vbModal
    If MostrarConsulta!Command1.Caption = "" Then
        Unload MostrarConsulta
    Else
        MostrarConsulta.Show
    End If
End Sub

Private Sub mnuConsultaSQL_Click()
    fExecute.Show , Me
End Sub

Private Sub mnuEd_Click()
    'Llama al procedimiento genérico de edición     (31/Ago/97)
    menuEdi
End Sub

Private Sub mnuEdicion_Click(Index As Integer)
    'Procedimiento genérico de los comandos de edición  (31/Ago/97)
    menuEdicion Index
End Sub

Private Sub mnuGuardar_Click()
    cmdAccion_Click CMD_Actualizar
End Sub

Private Sub mnuNuevo_Click()
    cmdAccion_Click CMD_Nuevo
End Sub

Private Sub mnuNuevoAvan_Click()
    cmdAccion_Click CMD_NuevoAvan
End Sub

Private Sub mnuPegarAvan_Click()
    cmdAccion_Click CMD_PegarAvan
End Sub

Private Sub mnuReg_Click()
    'Por si se quiere habilitar sólo
    'si el campo de texto actual es cDescripcion        ( 1/Sep/97)
    'mnuRegImprimir.Enabled = (ControlActual = cDescripcion)
End Sub

Private Sub mnuRegAmpDesc_Click()
    Dim Index As Integer
    
    If ActiveControl.Name = "Text1" Then
        Index = ActiveControl.Index
        
        'Si es el cuadro de asunto o descripción
        'mostrar el form del Mini-Editor
        Select Case Index
        Case cAsunto, cDescripcion
            With fMiniEditor
                '.cmdImprimir.Enabled = False
                If Index = cDescripcion Then
                    .txtEditor.Text = RichTextBox1.Text
                Else
                    .txtEditor.Text = Text1(Index).Text
                End If
                .Show vbModal
                If iFFAccion <> cFFAc_Cancelar Then
                    'aceptar el texto
                    If Index = cDescripcion Then
                        RichTextBox1.Text = .txtEditor.Text
                    Else
                        Text1(Index).Text = .txtEditor.Text
                    End If
                End If
            End With
            Unload fMiniEditor
            'restablecer el archivo de configuración actual
            sFFIni = sFicIni
        End Select
    End If
End Sub

Private Sub mnuRegBuscar_Click()
    cmdAccion_Click CMD_Buscar
End Sub

Private Sub mnuRegBuscarSig_Click()
    cmdAccion_Click CMD_BuscarSiguiente
End Sub

Private Sub mnuRegDatoAnterior_Click()
    'asignar al campo actual el dato anterior
    'sólo se "recuerdan" los datos guardados con el comando
    'actualizar del menú, barra herramientas o F9
    '
    'Se tiene en cuenta cuando se cambia el registro    (16/Sep/97)
    '
    If ControlActual = 0 Then Exit Sub
    If Len(Trim$(Campos(ControlActual).Anterior)) Then
        If ControlActual = cDescripcion Then
            RichTextBox1.Text = Campos(ControlActual).Anterior
        Else
            Text1(ControlActual).Text = Campos(ControlActual).Anterior
        End If
    End If
End Sub

Private Sub mnuRegImprimir_Click()
    'Imprimir sólo el campo descripción
    gsImprimir RichTextBox1
End Sub

Private Sub MostrarLinea(qControl As Control)
    Dim TotalLineas As Long
    Dim LineaActual As Long
    Const EM_GETLINECOUNT = &HBA
    Const EM_LINEFROMCHAR = &HC9
    
    TotalLineas = SendMessage(qControl.hWnd, EM_GETLINECOUNT, 0, 0&)
    LineaActual = SendMessage(qControl.hWnd, EM_LINEFROMCHAR, -1, 0&) + 1
    LblStatus(2) = "Lín:" & LineaActual & " de " & TotalLineas
End Sub

Private Sub mnuRegReemplazar_Click()
    cmdAccion_Click CMD_Reemplazar
End Sub

Private Sub mnuSalir_Click()
    Unload Me
    End
End Sub

Private Sub mnuSelecBase_Click()
    ' Cargar frmEntrada y cerrar este formualario                   (10/Nov/00)
    '
    gNoCargar = True                    ' Para no procesar la línea de comandos
    Unload Me                           ' Primero cerrar este formulario
    ' Desde frmEntrada se cargará de nuevo este formulario
    frmEntrada.Show
End Sub

Private Sub RichTextBox1_Click()
    LblStatus(0) = "(" & RichTextBox1.SelStart + 1 & "/" & RichTextBox1.MaxLength & ")"
    MostrarLinea RichTextBox1
End Sub

Private Sub RichTextBox1_DblClick()
    With fMiniEditor
        '.cmdImprimir.Enabled = False
        '.txtEditor.FontName = "Courier New"
        .txtEditor.Text = RichTextBox1.Text
        .Show vbModal
        If iFFAccion <> cFFAc_Cancelar Then
            'aceptar el texto
            RichTextBox1.Text = .txtEditor.Text
        End If
    End With
    Unload fMiniEditor
    'restablecer el archivo de configuración actual
    sFFIni = sFicIni
End Sub

Private Sub RichTextBox1_GotFocus()
    ControlActual = cDescripcion
End Sub

Private Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer)
    LblStatus(0) = "(" & RichTextBox1.SelStart + 1 & "/" & RichTextBox1.MaxLength & ")"
    MostrarLinea RichTextBox1
End Sub

Private Sub RichTextBox1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        PopupMenu mnuEd
    End If
End Sub

Private Sub RichTextBox1_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    '
    'Aceptar archivos dejados
    '
    Dim nFic As Integer
    Dim sNombre As String
    
    On Local Error Resume Next
    
    sNombre = Data.Files.Item(1)
    
    nFic = FreeFile
    Open sNombre For Input As nFic
    RichTextBox1.Text = Input$(LOF(nFic), nFic)
    Close nFic
    
    Err = 0
    On Local Error GoTo 0
    
End Sub

Private Sub Text1_Click(Index As Integer)
    LblStatus(0) = "(" & Text1(Index).SelStart + 1 & "/" & Text1(Index).MaxLength & ")"
    Select Case Index
    Case cAsunto ', cDescripcion
        MostrarLinea Text1(Index)
    Case Else
        LblStatus(2) = ""
    End Select
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    'Esta variable se asignará cada vez que el control reciba el foco
    ControlActual = Index
    If Index = cDescripcion Then
        RichTextBox1.SetFocus
    End If
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
    Dim sTmp As String
    
    ' Para los campos de fecha
    If Campos(Index).Tipo = adDate Then
        Select Case KeyAscii
        Case Asc("-"), Asc("."), Asc("/")
            KeyAscii = Asc(sSepFecha)
        Case vbKeyReturn
            Text1(Index) = AjustarFecha(Text1(Index))
        End Select
    End If
    If KeyAscii = vbKeyReturn Then
        KeyAscii = 0
        Select Case Index
        Case cDescripcion, cAsunto
            ' Nada, son campos multiline
        Case cFecha
            Text1(cFechaInicio).SetFocus
        Case cFechaInicio
            Text1(cFechaTermino).SetFocus
        Case cFechaTermino
            Check1.SetFocus
        Case Else
            SendKeys "{TAB}"
        End Select
    End If
End Sub

Private Sub Text1_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
    LblStatus(0) = "(" & Text1(Index).SelStart + 1 & "/" & Text1(Index).MaxLength & ")"
    Select Case Index
    Case cAsunto ', cDescripcion
        MostrarLinea Text1(Index)
    Case Else
        LblStatus(2) = ""
    End Select
End Sub

Private Sub Text2_GotFocus()
    
    SeleccionarTexto Text2
    ControlActual = 0
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.Find "c1ID = " & CStr(TxtID), 1
                Data1.Find "c1ID = " & CStr(TxtID), , adSearchForward, 1
                If Data1.EOF Then
                    Beep
                    Data1.MoveFirst
                End If
                '***Data1.Seek "=", TxtID
                Text2.Text = Data1!c1ID
            End If
        End If
    End If
End Sub

Private Sub Form_Load()
    Dim sTmp As String
    Dim i As Long
    '
    Check1.Value = vbUnchecked
    '
    LblStatus(2) = ""
    
    sSepFecha = "/"
    
    sTmp = Format$(Now, "Short Date")
    If InStr(sTmp, "/") Then
        sSepFecha = "/"
    ElseIf InStr(sTmp, "-") Then
        sSepFecha = "-"
    ' Si usas algún separador "predefinido" incluyelo aquí
    End If
    
    LblStatus(0).Caption = ""
    ' Asignar la línea de estado
    Set LineaEstado = LblStatus(1)
    ' Asignar este form
    Set elForm = Me
    
    ' El tamaño por defecto
    iH = Height
    iW = Width
    
    ' Añadir el short-cut de Alt+F4 a la opción Salir:
    mnuSalir.Caption = "&Salir" & Chr$(9) & "Alt+F4"
    
    ' El archivo de configuración
    sFFIni = sFicIni
    ' le damos tiempo para que haga el Resize
    DoEvents
    
    sClasif = Trim$(gCD.LeerIni(sFicIni, "General", "Clasif_" & sUsuario, "c1ID"))
    If Len(sClasif) = 0 Then
        sClasif = "c1ID"
    End If
    
    ' Ahora podemos asignar el tamaño y posición que tenía antes:
    Dim tL&, tT&, tW&, tH&
    tL = Val(gCD.LeerIni(sFicIni, "Posición_" & sUsuario, "gsNotas_Left", CStr(Left)))
    tT = Val(gCD.LeerIni(sFicIni, "Posición_" & sUsuario, "gsNotas_Top", CStr(Top)))
    tW = Val(gCD.LeerIni(sFicIni, "Posición_" & sUsuario, "gsNotas_Width", CStr(Width)))
    tH = Val(gCD.LeerIni(sFicIni, "Posición_" & sUsuario, "gsNotas_Height", CStr(Height)))
    ' Asignamos el nuevo tamaño
    Move tL, tT, tW, tH
    '
    ' Si estaba maximizado...
    If Val(gCD.LeerIni(sFicIni, "Posición_" & sUsuario, "gsNotas_Maximizado", "0")) Then
        WindowState = vbMaximized
    End If
    '
    NumApartadosAnt = 1
    '
    NumApartados = Val(gCD.LeerIni(sFicIni, "Apartados_" & sUsuario, "Numero", "0"))
    If NumApartados < 1 Then
        With cboApartados
            .Clear
            '.AddItem "Mensajes"
            .AddItem "Notas"
            '.AddItem "Tips"
            .ListIndex = 0
            '
            NumApartados = 1
            gCD.GuardarIni sFicIni, "Apartados_" & sUsuario, "Numero", CStr(NumApartados)
            For i = 0 To NumApartados - 1
                gCD.GuardarIni sFicIni, "Apartados_" & sUsuario, "Nombre" & CStr(i), .List(i)
            Next
        End With
    Else
        LeerApartados
    End If
    
    Show
    DoEvents
    ' Cargar la tabla
    CargarTabla
    ' cargar el form de los bookmarks    (16/Sep/97)
    Load fBookmarks
    
    ' Mostrar Todos los mensajes
    cmdView_Click 0
    
    SeleccionarTexto Text1(1)
    DoEvents
End Sub

Private Sub SeleccionarTexto(unControl As Control)
    If TypeOf unControl Is TextBox Then
        With unControl
            If .MaxLength < 50 Then
                .SelStart = 0
                .SelLength = Len(.Text)
            End If
        End With
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    '
    ' Cerrar la base y destruir el objeto                ( 5/Jul/97)
    RsBuscar.Close
    Set RsBuscar = Nothing
    Data1.Close
    Set Data1 = Nothing
    'Db.Close
    'Set Db = Nothing
    Cnn.Close
    Set Cnn = Nothing
    
    ' Sólo si está mostrada de forma normal
    If WindowState = vbNormal Then
        gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Left", CStr(Left)
        gCD.GuardarIni sFicIni, "Posición_" & sUsuario, "gsNotas_Top", CStr(Top)
    End If
    
    'Unload fBookmarks
    ' Descargar todos los formularios                               (01/Oct/01)
    Dim unForm As Form
    '
    For Each unForm In Forms
        Unload unForm
    Next
    '
    Set gsNotas = Nothing
    'End
End Sub

Private Sub Accion(Index As Integer)
    ' para procesar las otras acciones adicionales   (15/Abr/97)
    Select Case Index
    Case CMD_BookmarkLista To CMD_BookmarkSiguiente
        mnuBookmarks_Click Index - CMD_BookmarkLista
    Case CMD_Salir
        mnuSalir_Click
    Case CMD_Acerca
        mnuAcercaDe_Click
    Case CMD_Consulta
        mnuConsulta_Click
    Case CMD_Clasificar
        ' mostrar la ventana de selección de campos y clasificar...
        With frmCampos
            .Caption = "Orden de clasificación"
            .Text1 = sClasif
            .Show vbModal
            sClasif = .Text1
        End With
        Unload frmCampos
        If Len(sClasif) Then
            YaEstoyAqui = True
            ' Clasificar por esa selección
            On Local Error Resume Next
            '
            NoActualizar = True
            '
            Data1.Close
            Set Data1 = Nothing
            Set Data1 = New ADODB.Recordset
            Data1.Open "select * from " & sTabla & " order by " & sClasif, Cnn, adOpenDynamic, adLockOptimistic
            'Data1.RecordSource = "select * from " & sTabla & " order by " & sClasif
            'Data1.Refresh
            Data1.MoveLast
            If Data1.EOF Then
                Err = 0
                Data1.Open "select * from " & sTabla & " order by ID", adOpenDynamic, adLockOptimistic
                'Data1.RecordSource = "select * from " & sTabla & " order by ID"
                'Data1.Refresh
            End If
            '
            NoActualizar = False
            Data1.MoveLast
            '
            Err = 0
            On Local Error GoTo 0
            gCD.GuardarIni sFicIni, "General", "Clasif_" & sUsuario, sClasif
            YaEstoyAqui = False
        End If
    Case CMD_Compactar
        YaEstoyAqui = True
        CompactarBase
        YaEstoyAqui = False
        Data1.MoveLast
    Case CMD_Configurar
        NumApartadosAnt = NumApartados
        ' Mostrar la ventana de configuración                       (07/Ago/00)
        cfgApartados.Show vbModal
        ' Leer los apartados, por si se ha modificado
        LeerApartados
    Case Else
        cmdAccion_Click Index
    End Select
    LblStatus(1) = LblStatus(1).Tag
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As Button)
    Accion Button.Index
End Sub

Private Function BuscarEnBase(Optional ByVal sBusqueda As String = "") As Long
    ' Devuelve el número de ID                           ( 5/Jul/97)
    Dim sSQL As String
    Dim lID As Long
    
    On Local Error Resume Next
    
    If Len(sBusqueda) Then
        sSQL = "SELECT c1ID FROM " & sTabla & " WHERE " & sBusqueda
        'Set RsBuscar = Db.OpenRecordset(sSQL, dbOpenSnapshot)
        ' De esta forma, sólo se puede ir hacia adelante
        'Set RsBuscar = Cnn.Execute(sSQL)
        Set RsBuscar = New ADODB.Recordset
        RsBuscar.Open sSQL, Cnn, adOpenStatic, adLockOptimistic
        '
        If Not RsBuscar.EOF Then
            'Si se hace esto, se tarda más en encontrar el primero
            'si se quita, el primero lo encuentra muy rápido...
            'pero el siguiente, tarda un poco más...
            '(porque tiene que rellenar todo el recordset...)
            'RsBuscar.MoveLast
            'RsBuscar.MoveFirst
            ' Primera búsqueda
            If buscAtras Then
                RsBuscar.MoveLast
            End If
            lID = CLng(RsBuscar("c1ID"))
        Else
            lID = 0&
        End If
    Else
        If buscAtras Then
            RsBuscar.MovePrevious
        Else
            RsBuscar.MoveNext
        End If
        lID = CLng(RsBuscar("c1ID"))
    End If
    If (lID = 0&) Or (Err <> 0) Then
        lID = 0&
        'para que al seguir buscando se empiece por el primero
        If buscAtras Then
            RsBuscar.MoveLast
            RsBuscar.MoveNext
        Else
            RsBuscar.MoveFirst
            RsBuscar.MovePrevious
        End If
    End If
    Err = 0
    BuscarEnBase = lID
End Function

Private Sub PegarMensaje()
    'Pegar del portapapeles un mail copiado         ( 2/Ago/97)
    'Se pegará en el campo Descripción
    'si es un mail, (tiene: Asunto:/Subject:... To:/A:)
    'se copiarán las primeras líneas en el campo Asunto y
    'se añadirá al final del mensaje: ---xxx--- & vbCrLf
    '
    Dim sTmp As String
    Dim sDescripcion As String
    Dim esMensaje As Boolean
    Dim i As Long
    Dim sAsunto As String
    Dim j As Long
    Dim k As Long
    
    Dim queBuscar As Variant
    Dim numBuscar As Integer
    
    queBuscar = Array("Subject:", "Asunto:", "From:", "De:", "To:", "A:", "Para:", "Date:", "Fecha:", "Organization:", "References:")
    
    On Local Error Resume Next
    
    'If Clipboard.GetFormat(vbCFRTF) Then       ' RTF
    '    'Aunque sea RTF, guardarlo como Texto
    '    RichTextBox1.Text = RichTextBox1.Text & _
    '                        Clipboard.GetText() & vbCrLf & "---xxx---" & vbCrLf
    '    'guardarlo
    '    DoEvents
    '    cmdAccion_Click CMD_Actualizar
    '    Exit Sub
    'Else
    '    sTmp = Clipboard.GetText()
    '    If Len(sTmp) > 32000 Then
    '        RichTextBox1.Text = RichTextBox1.Text & sTmp & vbCrLf & "---xxx---" & vbCrLf
    '        'guardarlo
    '        DoEvents
    '        cmdAccion_Click CMD_Actualizar
    '        Exit Sub
    '    End If
    'End If
    
    
    sTmp = Clipboard.GetText()
    If Err Then sTmp = ""
    'Si no hay nada en el clipboard salir
    If Len(Trim$(sTmp)) = 0 Then
        Err = 0
        Exit Sub
    End If
    
    Err = 0
    
    If Len(sTmp) > 32000 Then
        RichTextBox1.Text = RichTextBox1.Text & sTmp & vbCrLf & "---xxx---" & vbCrLf
        'guardarlo
        DoEvents
        cmdAccion_Click CMD_Actualizar
        Exit Sub
    End If
    
    'Esta será la parte a añadir a Asunto
    'Cojer las primeras líneas hasta que haya 2 vbCrLf
    i = InStr(sTmp, (vbCrLf & vbCrLf))
    If i Then
        sAsunto = Left$(sTmp, i - 1)
    Else
        i = InStr(sTmp, vbCrLf)
        If i Then _
            sAsunto = Left$(sTmp, i - 1)
    End If
    'Por si es demasiado largo...
    sAsunto = Left$(sAsunto, 255)
    
    'Comprobar si es un mensaje, creo que con estas es suficiente
    If InstrVarios(1, sTmp, queBuscar) Then
        esMensaje = True
    End If
    
    'If InStr(sTmp, "Asunto:") Then
    '    esMensaje = True
    'ElseIf InStr(sTmp, "Subject:") Then
    '    esMensaje = True
    ''Si un mensaje no viene con "asunto", estas estarán...
    'ElseIf InStr(sTmp, "To:") Then
    '    esMensaje = True
    'ElseIf InStr(sTmp, "A:") Then
    '    esMensaje = True
    'End If
    'En caso que sea Self, es que es una respuesta,
    'por tanto sólo se pegará
    If InStr(sTmp, "Self") Then _
        esMensaje = False
    
    'si ya hay texto en Asunto, no tomarlo como mensaje nuevo
    If Len(Trim$(Text1(cAsunto).Text)) Then
        esMensaje = False
    Else
        'en caso contrario, si no es un mensaje normal,
        'poner algo en el asunto                    ( 3/Sep/97)
        If esMensaje = False Then _
            esMensaje = True
    End If
    
    sDescripcion = RTrim$(RichTextBox1.Text)
    'Quitar los intros del final
    sTmp = Trim$(sTmp)                      'Hecho el 13/Ago/97
    Do While Right$(sTmp, 2) = vbCrLf
        sTmp = Left$(sTmp, Len(sTmp) - 2)
    Loop
    'Quitar los vbCrLf del principio                (16/Sep/97)
    Do While Left$(sTmp, 2) = vbCrLf
        sTmp = Mid$(sTmp, 3)
    Loop
    'Quitar los vbCr del principio
    Do While Left$(sTmp, 1) = vbCr
        sTmp = Mid$(sTmp, 2)
    Loop
    'Quitar los vbLf del principio
    Do While Left$(sTmp, 1) = vbLf
        sTmp = Mid$(sTmp, 2)
    Loop
    'Quitar los espacios del principio
    sTmp = LTrim$(sTmp)
    
    
    'Para los mensajes del Netscape...              (22/Nov/97)
    
    'Quitar los Chr$(0)
    Do While Left$(sTmp, 1) = Chr$(0)
        sTmp = Mid$(sTmp, 2)
    Loop
    
    'Quitar los intros después de : hasta el primer carácter
    'Pero sólo si es una línea con Subject, etc.    (22/Feb/98)
    '
    For numBuscar = 0 To UBound(queBuscar)
        i = 1
        Do
            j = InStr(i, sTmp, queBuscar(numBuscar))
            If j Then
                i = j + Len(queBuscar(numBuscar)) + 1
                k = j + Len(queBuscar(numBuscar)) + 1
                Do
                    If Mid$(sTmp, k, 2) = vbCrLf Then
                        sTmp = Left$(sTmp, k - 1) & Mid$(sTmp, k + 2)
                        k = k - 1
                    ElseIf Mid$(sTmp, k, 1) <> " " Then
                        i = k
                        Exit Do
                    End If
                    k = k + 1
                Loop
            End If
        Loop While j
    Next
    
    'Quitar los espacios desde el vbCrLf hasta la primera letra
    i = 1
    Do
        'DoEvents
        j = InStr(i, sTmp, vbCrLf)
        If j Then
            i = j + 1
            k = j + 1
            Do While Mid$(sTmp, k, 1) = " "
                sTmp = Left$(sTmp, k - 1) & Mid$(sTmp, k + 1)
                k = k + 1
            Loop
        End If
        'If Err Then Exit Do
    Loop While j
    '
    If Len(sDescripcion) Then
        sDescripcion = sDescripcion & vbCrLf & sTmp & vbCrLf & "---xxx---" & vbCrLf
    Else
        sDescripcion = sTmp & vbCrLf & "---xxx---" & vbCrLf
    End If
    RichTextBox1.Text = LTrim$(sDescripcion)
    
    If esMensaje Then
        sAsunto = Trim$(sAsunto)
        'Quitar los intros del final
        Do While Right$(sAsunto, 2) = vbCrLf
            sAsunto = Left$(sAsunto, Len(sAsunto) - 2)
        Loop
        'Quitar los intros del principio
        Do While Left$(sAsunto, 2) = vbCrLf
            sAsunto = Mid$(sAsunto, 3)
        Loop
        '
        'Quitar los vbCrLf después de : hasta la primera letra
        '
        i = 1
        Do
            j = InStr(i, sAsunto, ":")
            If j Then
                i = j + 1
                k = j + 1
                Do
                    If Mid$(sAsunto, k, 2) = vbCrLf Then
                        sAsunto = Left$(sAsunto, k - 1) & Mid$(sAsunto, k + 2)
                        k = k - 1
                    ElseIf Mid$(sAsunto, k, 1) <> " " Then
                        i = k
                        Exit Do
                    End If
                    k = k + 1
                Loop While k < Len(sAsunto)
            End If
        Loop While j
        '
        'Quitar los espacios después de cada vbCrLf
        i = 1
        Do
            j = InStr(i, sAsunto, vbCrLf)
            If j Then
                i = j + 1
                k = j + 3
                Do While Mid$(sAsunto, k, 1) = " "
                    sAsunto = Left$(sAsunto, k - 1) & Mid$(sAsunto, k + 1)
                    k = k + 1
                Loop
            End If
        Loop While j
        
        'Si en asunto está guille@ o guiller@, quitarlo (17/Sep/97)
        i = 0
        If InStr(sAsunto, "guille@") Then
            i = InStr(sAsunto, "guille@")
        ElseIf InStr(sAsunto, "guiller@") Then
            i = InStr(sAsunto, "guiller@")
        End If
        If i Then
            sTmp = ""
            'buscar el intro anterior y el siguiente
            'el anterior
            For j = i To 1 Step -1
                If Mid$(sAsunto, j, 2) = vbCrLf Then
                    sTmp = Left$(sAsunto, j + 1)
                    Exit For
                End If
            Next
            'el siguiente
            For j = i To Len(sAsunto)
                If Mid$(sAsunto, j, 2) = vbCrLf Then
                    sTmp = sTmp & Mid$(sAsunto, j + 2)
                    Exit For
                End If
            Next
            If Len(sTmp) Then
                sAsunto = sTmp
            End If
        End If
        'añadir el Asunto
        Text1(cAsunto).Text = sAsunto
    End If
    'guardarlo
    DoEvents
    cmdAccion_Click CMD_Actualizar
End Sub

Private Function InstrVarios(ByVal posInicio As Long, ByVal queCadena As String, ByVal queBusco As Variant) As Long
    'Esta función devolverá la posición en la que está
    'cualquiera de las palabras que se pasan en el parámetro
    'queBusco, que será un array
    '
    'Realmente devuelve la primera coincidencia
    '
    Dim i&, j&
    
    On Local Error Resume Next
    
    j = 0
    For i = 0 To UBound(queBusco)
        j = InStr(posInicio, queCadena, queBusco(i))
        If j Then
            'Hallado, salir
            Exit For
        End If
    Next
    InstrVarios = j
    Err = 0
End Function

Private Sub TestDataChanged(unControl As Control)
' Referencia: Microsoft TechNet International PSS ID Number: E10626
'
    On Local Error Resume Next
    
    If unControl.DataChanged Then           ' Detectamos si el cuadro de texto ha
                                            ' sido editado
        ' Esto creo que se debe hacer...
        ' sino, ¿que sentido tiene asignar Null?
        If unControl = "" Then              ' Si el valor está vacio
            unControl.DataChanged = False   ' Cambiando esta propiedad, el control
                                            ' Data no tendrá constancia de que el
                                            ' cuadro de texto asociado ha sido
                                            ' editado.
            Data1.Update  'Record              ' Salvamos los demás controles
                                            ' asociados al control Data.
            'Data1.Edit
            Data1.Fields(unControl.DataField) = Null
            Data1.Update
        End If
    End If
    
    Err = 0
End Sub

Private Sub AñadirRegistro()
'Procedimiento sacado de Microsoft TechNet International
'Error 3426 al actualizar un registro de un datacontrol
'PSS ID Number: E10143
'
'    Dim rAux As Recordset
    Dim iContador As Long
    
'    Set rAux = Data1
    ' data1 es un control de datos
    
    ' Ahora se desvincula el Recordset del control de datos
    'Set Data1 = Nothing
    
    ' La operación de añadir registro se realiza sobre la
    ' variable auxiliar
    Data1.AddNew
    '
    For iContador = cID To cTerminada
        If iContador = cDescripcion Then
            RichTextBox1.Text = ""
        Else
            Text1(iContador).Text = ""
        End If
    Next
    Text1(cFecha).Text = Format$(Now, "dd/mm/yyyy")
    Text1(cFechaInicio).Text = Text1(cFecha).Text
    Text1(cTerminada).Text = "0"
    
'    ' Se rellena el registro con los datos introducidos
'    ' por el usuario
'    'Empezamos por UNO para no actualizar el ID
'    For iContador = 1 To rAux.Fields.Count - 1
'
'        If iContador = cDescripcion Then
'            rAux(iContador) = RichTextBox1.Text & " "
'        Else
'            If Text1(iContador) = "" Then
'                ' Le he añadido esta comparación, ya que daba error
'                ' en el campo de fecha término           ( 4/Jul/98)
'                ' al menos cuando se creaba el primer registro.
'                If rAux(iContador).Type = dbDate Then
'                    rAux(iContador) = Null
'                Else
'                    rAux(iContador) = Text1(iContador).Text & " "
'                End If
'            Else
'                rAux(iContador) = Text1(iContador).Text
'            End If
'        End If
'
'    Next
'
'    rAux.Update
'
'    ' Por último se asigna el Recordset al control de datos
'    Set Data1 = rAux
'
'    ' Si se quisiera actualizar los controles asociados al
'    ' control de datos con el nuevo registro, habría que
'    ' quitar los comentarios a la siguiente línea
'    'Data1.UpdateControls
'
End Sub

Private Sub LeerApartados()
    ' Lee los valores del fichero INI y asigna los botones, etc.    (07/Ago/00)
    Dim i As Long
    
    On Local Error Resume Next
    
    With cboApartados
        .Clear
        For i = 0 To NumApartados - 1
            .AddItem gCD.LeerIni(sFicIni, "Apartados_" & sUsuario, "Nombre" & CStr(i), "")
            asApartados(i) = gCD.LeerIni(sFicIni, "Apartados_" & sUsuario, "Imagen" & CStr(i), "")
        Next
        .ListIndex = 0
    End With
    ' Eliminar los botones anteriores
    For i = NumApartadosAnt To 1 Step -1
        Unload cmdView(i)
    Next
    ' Crear los botones
    For i = 1 To NumApartados
        Load cmdView(i)
        With cmdView(i)
            .Caption = cboApartados.List(i - 1)
            .FontBold = False
            If Len(Dir$(asApartados(i - 1))) Then
                .Picture = LoadPicture(asApartados(i - 1))
                .Height = 795
            End If
            .Top = cmdView(i - 1).Top + cmdView(i - 1).Height + 30
            '.Style = vbButtonGraphical ' (es de sólo lectura)
            .Visible = True
        End With
    Next
    '
    NumApartadosAnt = NumApartados
    
    ' Mostrar Todos los mensajes
    cmdView_Click 0
End Sub

Private Sub ActualizarRegistro()
    Dim i As Long
    Dim sTmp As String
    '
    On Error GoTo ErrActualizar
    '
    With Data1
        'Err = 0
        Text1(cApartado).Text = cboApartados.Text
        Text1(cTerminada).Text = Check1.Value
        For i = 1 To Text1.Count - 1
            If i = cDescripcion Then
                .Fields(RichTextBox1.DataField) = RichTextBox1.Text & ""
            Else
                If .Fields(Text1(i).DataField).Type = adDate Then ' dbDate
                    If Text1(i).Text <> "" Then
                        .Fields(Text1(i).DataField) = Text1(i).Text
                    End If
                ElseIf .Fields(Text1(i).DataField).Type = adInteger Then
                    .Fields(Text1(i).DataField) = Text1(i).Text + 0
                Else
                    .Fields(Text1(i).DataField) = Text1(i).Text & ""
                End If
            End If
        Next
        .Update
        ' A ver si así se actualiza correctamente
        If Val(!c7Terminada) Then
            Check1.Value = 1
        Else
            Check1.Value = 0
        End If
        Check1_Click
        '
        If Not .EOF Then
            If Not IsNull(!c1ID) Then _
                sTmp = !c1ID
            
            If Not IsNull(!c2Fecha) Then _
                sTmp = sTmp & ", " & !c2Fecha
                
            If Not IsNull(!c3Asunto) Then _
                sTmp = sTmp & ", " & !c3Asunto
                
            If Len(sTmp) Then
                Data1Caption = QuitarCaracter(sTmp, vbCrLf, " ")
            Else
                Data1Caption = " Registro en blanco."
            End If
        Else
            Data1Caption = "No hay registros."
            Text2.Text = Null
        End If
    End With
    '
    Exit Sub
    '
ErrActualizar:
    Debug.Assert Err.Number = 0
    If i < Text1.Count - 1 Then
        MsgBox "Error al actualizar el registro, campo: " & Text1(i).DataField & vbCrLf & _
            Err.Number & " " & Err.Description
    Else
        MsgBox "Error al actualizar el registro." & vbCrLf & _
            Err.Number & " " & Err.Description
    End If
End Sub

Friend Function BuscarEnData(ByVal sID As String) As Boolean
    ' Si no se haya, devolverá TRUE                                 (01/Oct/01)
    '
    'Data1.Find "c1ID = " & CLng(sID), 1
    Data1.Find "c1ID = " & CLng(sID), , adSearchForward, 1
    If Data1.EOF Then
        Data1.MoveFirst
        BuscarEnData = True
    End If
End Function

El resto de los formularios:

cfgApartados (configuración de los apartados a usar)


'------------------------------------------------------------------------------
' Configurar los botones de los apartados                           (07/Ago/00)
'
' ©Guillermo 'guille' Som, 2000-2001
'------------------------------------------------------------------------------
Option Explicit

' Constantes para los índices de los botones de apartados           (08/Ago/00)
Const cNuevo As Long = 0
Const cAsignar As Long = 1
Const cBorrar As Long = 2
Const cExaminar As Long = 3

Private Sub cboApartados_Change()
    ' Mostrar en los Text1 los valores actuales                     (07/Ago/00)
    On Local Error Resume Next
    
    Text1(0) = cboApartados.Text
    Text1(1) = asApartados(cboApartados.ListIndex)
    Image1.Picture = LoadPicture(asApartados(cboApartados.ListIndex))
End Sub

Private Sub cboApartados_Click()
    ' Mostrar en los Text1 los valores actuales                     (07/Ago/00)
    On Local Error Resume Next
    
    Text1(0) = cboApartados.Text
    Text1(1) = asApartados(cboApartados.ListIndex)
    Image1.Picture = LoadPicture(asApartados(cboApartados.ListIndex))
End Sub

Private Sub cmdAceptar_Click()
    ' Guardar los nuevos apartados y asignar los datos
    Dim i As Long
    
    gCD.GuardarIni sFicIni, "Apartados_" & sUsuario, "Numero", CStr(NumApartados)
    For i = 0 To NumApartados - 1
        gCD.GuardarIni sFicIni, "Apartados_" & sUsuario, "Nombre" & CStr(i), cboApartados.List(i)
        gCD.GuardarIni sFicIni, "Apartados_" & sUsuario, "Imagen" & CStr(i), asApartados(i)
    Next
    
    Unload Me
End Sub

Private Sub cmdApartados_Click(Index As Integer)
    ' Seleccionar la imagen para el botón                           (07/Ago/00)
    Dim CommonDialog1 As cgsFileOp
    Dim i As Long, j As Long
    Dim sApartado As String
    
    On Local Error Resume Next
    
    i = cboApartados.ListIndex
    sApartado = cboApartados.List(i)
    
    Select Case Index
    Case cNuevo
        ' Añadir lo que está escrito como nueva entrada
        ' (si no estaba antes)
        NumApartados = NumApartados + 1
        cboApartados.AddItem "Nuevo"
        cboApartados.ListIndex = cboApartados.ListCount - 1
    Case cAsignar
        ' Asignar los valores actuales al apartado seleccionado del combo
        cboApartados.List(i) = Text1(0)
        asApartados(i) = Text1(1)
    Case cBorrar
        ' Borrar el apartado seleccionado en el combo
        ' (confirmarlo antes)
        If MsgBox("¿Seguro que quieres borrar el apartado: '" & sApartado & "' ?", vbYesNo, "Borrar apartado") = vbYes Then
            cboApartados.RemoveItem i
            For j = i + 1 To NumApartados - 1
                asApartados(j - 1) = asApartados(j)
            Next
            NumApartados = NumApartados - 1
        End If
    Case cExaminar
        Set CommonDialog1 = New cgsFileOp
        
        With CommonDialog1
            .hWnd = hWnd
            .DialogTitle = "Seleccionar Base de Datos"
            .Filter = "Imágenes|*.bmp;*.ico;*.gif;*.jpg|Todos los archivos (*.*)|*.*"
            .CancelError = True
            .ShowOpen
            If Err = 0 Then
                Text1(1).Text = .FileName
                If Len(Dir$(.FileName)) Then
                    Image1.Picture = LoadPicture(.FileName)
                End If
            End If
        End With
        
        Set CommonDialog1 = Nothing
    End Select
    
    Err = 0
End Sub

Private Sub cmdCancelar_Click()
    ' Si se cancela, nada que hacer
    Unload Me
End Sub

Private Sub Form_Load()
    ' Asignar los valores actuales de los apartados                 (07/Ago/00)
    Dim i As Long
    
    NumApartados = Val(gCD.LeerIni(sFicIni, "Apartados_" & sUsuario, "Numero", "0"))
    If NumApartados < 1 Then
        With cboApartados
            .Clear
            .AddItem "Notas"
            '
            NumApartados = 1
            gCD.GuardarIni sFicIni, "Apartados_" & sUsuario, "Numero", CStr(NumApartados)
            For i = 0 To NumApartados - 1
                gCD.GuardarIni sFicIni, "Apartados_" & sUsuario, "Nombre" & CStr(i), .List(i)
            Next
            .ListIndex = 0
        End With
    Else
        With cboApartados
            .Clear
            For i = 0 To NumApartados - 1
                .AddItem gCD.LeerIni(sFicIni, "Apartados_" & sUsuario, "Nombre" & CStr(i), "")
            Next
            .ListIndex = 0
        End With
    End If
End Sub

fBookmarks (lista de marcadores personalizables)


'------------------------------------------------------------------------------
' Manejo de una lista de bookmarks para gsNotas                     (16/Sep/97)
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit

Const eMostrar = 0
Const eSustituir = 1
Const eBorrar = 2
Const eCerrar = 3

Private Sub cmdBookm_Click(Index As Integer)
    Dim i As Integer
    Dim j As Integer
    
    With Lista
        Select Case Index
        Case eMostrar
            'mostrar en el form este item
            i = .ListIndex
            elForm.BuscarEnData CStr(.ItemData(i))
'            elForm.Data1.Find "ID = " & CStr(.ItemData(i)), 1
'            If elForm.Data1.EOF Then
'                elForm.Data1.MoveFirst
'            End If
            ActualizarToolBar
            Hide
        Case eSustituir
            'Sólo sustituir el comentario
            i = .ListIndex
            If i Then
                j = InStr(Texto, ",")
                If j Then
                    Texto = Mid$(Texto, j + 2)
                End If
                .List(i) = Format$(.ItemData(i), "00000") & ", " & Texto
            End If
        Case eBorrar
            'borrar todos los seleccionados
            For i = .ListCount - 1 To 0 Step -1
                If .Selected(i) Then
                    .RemoveItem i
                End If
            Next
            If .ListCount Then
                If .ListIndex < 0 Then
                    .ListIndex = 0
                End If
            End If
        Case eCerrar
            ActualizarToolBar
            Hide
        End Select
    End With
End Sub

Private Sub Form_Load()
    Const LB_SETHORIZONTALEXTENT = &H400 + 21
    Dim ScaleTmp As Long
    Dim TextLen As Long

    'Poner un scroll horizontal al ListBox
    ScaleTmp = ScaleMode
    ScaleMode = 3
    TextLen = 256 * TextWidth("a")
    If SendMessage(Lista.hWnd, LB_SETHORIZONTALEXTENT, TextLen, 0&) Then
    End If
    ScaleMode = ScaleTmp
    
    Texto = ""
    Lista.Clear
    'leer los valores anteriores
    Dim n As Long
    Dim i As Long, j As Long
    Dim lngID As Long
    Dim sAsunto As String
    
    With elForm
        Move .Left + (.ScaleWidth - Width) \ 2, (.ScaleHeight - Height) \ 2
    End With
    
    'Ahora podemos asignar el tamaño y posición que tenía antes:
    Dim tL&, tT&, tW&, tH&
    tL = Val(gCD.LeerIni(sFicIni, "Bookmarks_" & sUsuario, "Left", CStr(Left)))
    tT = Val(gCD.LeerIni(sFicIni, "Bookmarks_" & sUsuario, "Top", CStr(Top)))
    tW = Val(gCD.LeerIni(sFicIni, "Bookmarks_" & sUsuario, "Width", CStr(Width)))
    tH = Val(gCD.LeerIni(sFicIni, "Bookmarks_" & sUsuario, "Height", CStr(Height)))
    'Asignamos el nuevo tamaño
    Move tL, tT, tW, tH
    
    n = Val(gCD.LeerIni(sFicIni, "Bookmarks_" & sUsuario, "Total"))
    If n Then
        For i = 0 To n - 1
            sAsunto = gCD.LeerIni(sFicIni, "Bookmarks_" & sUsuario, "Item" & CStr(i))
            lngID = Val(gCD.LeerIni(sFicIni, "Bookmarks_" & sUsuario, "ID" & CStr(i)))
            With Lista
                ' Quitarle el número y añadirselo formateado        (26/Dic/99)
                j = InStr(sAsunto, ",")
                If j Then
                    sAsunto = Format$(lngID, "00000") & "," & Mid$(sAsunto, j + 1)
                Else
                    j = InStr(sAsunto, CStr(lngID))
                    If j Then
                        sAsunto = Format$(lngID, "00000") & "," & Mid$(sAsunto, j + Len(CStr(lngID)))
                    End If
                End If
                .AddItem sAsunto
                .ItemData(.NewIndex) = lngID
            End With
        Next
        If Lista.ListCount Then
            Lista.ListIndex = 0
            Lista_Click
        End If
    End If
    ActualizarToolBar
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    'si se pulsa en el botón de cerrar
    If UnloadMode = vbFormControlMenu Then
        cmdBookm_Click eCerrar
    End If
End Sub


Private Sub Form_Resize()
    'Asegurarnos de que no se actualice la primera vez que se carga.
    Static YaHeEstado As Boolean
    Dim i As Integer
    
    If WindowState = vbMinimized Then Exit Sub
    
    'Ajustar los tamaños
    Texto.Width = ScaleWidth - 195
    For i = eMostrar To eCerrar
        cmdBookm(i).Left = ScaleWidth - 960
    Next
    Lista.Width = ScaleWidth - 1185
    Lista.Height = ScaleHeight - 600
    
    If YaHeEstado Then
        'Guardar el tamaño y la posición
        gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Left", CStr(Left)
        gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Top", CStr(Top)
        gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Width", CStr(Width)
        gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Height", CStr(Height)
    End If
    YaHeEstado = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'guardar los valores de los bookmarks
    Dim n As Integer
    Dim i As Integer
    
    With Lista
        n = .ListCount
        gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Total", CStr(n)
        If n Then
            For i = 0 To n - 1
                gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Item" & CStr(i), .List(i)
                gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "ID" & CStr(i), CStr(.ItemData(i))
            Next
        End If
    End With
    
    'Sólo si está mostrada de forma normal
    If WindowState = vbNormal Then
        gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Left", CStr(Left)
        gCD.GuardarIni sFicIni, "Bookmarks_" & sUsuario, "Top", CStr(Top)
    End If
    
    Lista.Clear
    Set fBookmarks = Nothing
End Sub

Private Sub Lista_Click()
    Texto = Lista.List(Lista.ListIndex)
End Sub

Private Sub Lista_DblClick()
    cmdBookm_Click eMostrar
End Sub

Public Sub Nuevo(ByVal vID As Long, Optional ByVal vAsunto As Variant)
    'Añadir un nuevo bookmark a la lista
    Dim sTmp As String
    Dim sAsunto As String
    Dim i As Integer
    Dim j As Integer
    
    If Not IsMissing(vAsunto) Then
        sAsunto = QuitarCaracter(CStr(vAsunto), vbCrLf, " ")
    End If
    'buscar si existe, sino la añade
    With Lista
        j = 0
        For i = 0 To .ListCount - 1
            If .ItemData(i) = vID Then
                j = i
                Exit For
            End If
        Next
        'Filtar el Asunto para quitar los espacios extras...
        sAsunto = QuitarCaracterEx(sAsunto, "  ", " ")
        If j Then
            .List(j) = Format$(vID, "00000") & ", " & sAsunto
            .ListIndex = j
        Else
            .AddItem Format$(vID, "00000") & ", " & sAsunto
            .ItemData(.NewIndex) = vID
            .ListIndex = .ListCount - 1
        End If
    End With
    Texto = sAsunto
End Sub

Public Property Get Anterior() As Long
    'Devuelve el item anterior al que está seleccionado
    Dim i As Integer
    
    With Lista
        i = .ListIndex
        If i = 0 Then
            i = .ListCount - 1
        Else
            i = i - 1
        End If
        If i < 0 Then _
            i = 0
        .ListIndex = i
        Anterior = .ItemData(i)
    End With
    ActualizarToolBar
End Property

Public Property Get Siguiente() As Long
    'Devuelve el siguiente item
    Dim i As Integer
    
    With Lista
        i = .ListIndex
        If i = .ListCount - 1 Then
            i = 0
        Else
            i = i + 1
        End If
        If i >= .ListCount Then _
            i = 0
        .ListIndex = i
        Siguiente = .ItemData(i)
    End With
    ActualizarToolBar
End Property

Public Sub ActualizarToolBar()
    Dim bEnabled As Boolean
    
    If Lista.ListCount < 2 Then
        bEnabled = False
    Else
        bEnabled = True
    End If
    elForm!Toolbar1.Buttons("BookmarkAnterior").Enabled = bEnabled
    elForm!Toolbar1.Buttons("BookmarkSiguiente").Enabled = bEnabled
    Caption = "Bookmarks [" & Lista.ListCount & "]"
End Sub

Public Sub Borrar(ByVal vID As Long)
    Dim i As Integer
    Dim j As Integer
    
    'Borrar un bookmark de la lista
    With Lista
        j = 0
        For i = 0 To .ListCount - 1
            If .ItemData(i) = vID Then
                j = i
                Exit For
            End If
        Next
        If j Then
            .RemoveItem j
        End If
    End With
    ActualizarToolBar
End Sub

fExecute (realizar consultas directas con código SQL)


'------------------------------------------------------------------------------
' Formulario para ejecutar consultas en la base de datos            (03/Oct/01)
' usando instrucciones SQL
'
' ©Guillermo 'guille' Som, 2001
'------------------------------------------------------------------------------
Option Explicit

Private Sub cmdCerrar_Click()
    Unload Me
End Sub


Private Sub cmdExecute_Click()
    ' Ejecutar consulta y mostrar el resultado en el listview       (03/Oct/01)
    Dim s As String
    Dim tRst As ADODB.Recordset
    Dim tFld As ADODB.Field
    Dim tItem As ListItem
    Dim i As Long, j As Long
    '
    On Error GoTo ErrExecute
    '
    Text1.Text = Trim$(Text1.Text)
    '
    ' Guardar la consulta
    s = Text1.Text
    gCD.IniDeleteSection sFicIni, "Consulta"
    j = 0
    Do
        i = InStr(s, vbCrLf)
        If i Then
            j = j + 1
            gCD.IniWrite sFicIni, "Consulta", "Línea" & CStr(j), Left$(s, i - 1)
            s = Mid$(s, i + 2)
        End If
    Loop While i
    If Len(s) Then
        j = j + 1
        gCD.IniWrite sFicIni, "Consulta", "Línea" & CStr(j), s
    End If
    gCD.IniWrite sFicIni, "Consulta", "Líneas", CStr(j)
    '
    MousePointer = vbHourglass
    lblStatus.Caption = " Procesando los datos, un momento, por favor..."
    lblStatus.Refresh
    '
    Set tRst = Cnn.Execute(Text1.Text)
    If tRst.EOF Then
        With Err
            .Description = "No hay datos que coincidan con la consulta o está mal realizada"
            .Raise -1
        End With
        'MsgBox "No hay datos que coincidan con la consulta o está mal realizada", vbExclamation
        Exit Sub
    End If
    '
    ' Limpiar el ListView
    With ListView1
        .ListItems.Clear
        .ColumnHeaders.Clear
        ' Averiguar los campos que contiene la consulta realizada
        ' para añadirlos al listview
        ' Primero añadir las cabeceras
        For Each tFld In tRst.Fields
            i = tFld.ActualSize * 120
            If i < 900 Then
                i = 900
            ElseIf i > 5000 Then
                i = 5000
            End If
            If tFld.Type = adDate Then
                i = 1100
            End If
            .ColumnHeaders.Add , , tFld.Name, i
        Next
        ' Añadir los datos
        j = 0
        Do While Not tRst.EOF
            i = -1
            j = j + 1
            For Each tFld In tRst.Fields
                i = i + 1
                If Not IsNull(tRst.Fields(tFld.Name)) Then
                    If i = 0 Then
                        Set tItem = .ListItems.Add(, , CStr(tRst.Fields(tFld.Name)) & "")
                    Else
                        tItem.SubItems(i) = CStr(tRst.Fields(tFld.Name)) & ""
                    End If
                End If
            Next
            tRst.MoveNext
        Loop
    End With
    lblStatus.Caption = " Número de registros: " & CStr(j)
    lblStatus.Refresh
    '
    Set tRst = Nothing
    '
    MousePointer = vbDefault
    '
SalirExecute:
    Err.Clear
    Exit Sub
ErrExecute:
    MousePointer = vbDefault
    s = "ERROR: " & Err.Number & " " & Err.Description
    If Not tFld Is Nothing Then
        s = s & vbCrLf & "Campo: " & tFld.Name
    End If
    lblStatus.Caption = lblStatus.Tag
    lblStatus.Refresh
    MsgBox s, vbExclamation
    Resume SalirExecute
End Sub

Private Sub Form_Load()
    Dim s As String
    Dim i As Long, j As Long
    '
    lblStatus.Caption = " ©Guillermo 'guille' Som, 2001" & IIf(Year(Now) > 2001, "-" & CStr(Year(Now)), "")
    lblStatus.Tag = lblStatus.Caption
    '
    With ListView1
        .View = lvwReport
        .GridLines = True
        .MultiSelect = True
        .FullRowSelect = True
    End With
    '
    s = ""
    ' Recuperar la consulta anterior
    j = gCD.IniGet(sFicIni, "Consulta", "Líneas", "0")
    If j Then
        For i = 1 To j
            s = s & gCD.IniGet(sFicIni, "Consulta", "Línea" & CStr(i), "") & vbCrLf
        Next
    End If
    Text1.Text = s
End Sub


Private Sub Form_Resize()
    ' Ajustar el tamaño de los controles a la ventana               (03/Oct/01)
    If WindowState <> vbMinimized Then
        ' Tamaño mínimo 6000x4000
        If Width < 6000 Then
            Width = 6000
        End If
        If Height < 5000 Then
            Height = 5000
        End If
        With cmdCerrar
            .Top = ScaleHeight - 525
            cmdExecute.Top = .Top
            lblStatus.Top = .Top + 60
            .Left = ScaleWidth - 1395
            cmdExecute.Left = .Left - 1710
            lblStatus.Width = cmdExecute.Left - 315
        End With
        With Text1
            .Width = ScaleWidth - 300
            ListView1.Width = .Width
            ListView1.Height = cmdCerrar.Top - (.Top + .Height) - 180
        End With
    End If
End Sub

fMiniEditor


'------------------------------------------------------------------------------
' Form genérico para mostrar un texto                               (31/Ago/97)
' con algunas opciones de búsqueda, etc.
'
' Usando RichTextBox
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit

Dim bIniciandose As Boolean

Private Sub cmdAceptar_Click()
    'Aceptar
    iFFAccion = cFFAc_Aceptar
    Hide
End Sub

Private Sub cmdCancelar_Click()
    'cancelar
    iFFAccion = cFFAc_Cancelar
    Hide
End Sub

Private Sub cmdImprimir_Click()
    'imprimir
    
    cmdAceptar.Enabled = False
    cmdCancelar.Enabled = False
    With cmdImprimir
        .Caption = "Imprimiendo..."
        .Enabled = False
    End With
    
    gsImprimir txtEditor
    
    cmdAceptar.Enabled = True
    cmdCancelar.Enabled = True
    With cmdImprimir
        .Caption = "Imprimir"
        .Enabled = True
    End With
End Sub

Private Sub Form_Load()
    bIniciandose = True
    
    txtEditor.Move 60, 60
    sFFIni = gCD.AppPath(False) & "\miniEditor.ini"
    
    'Ajustar el tamaño y posición guardada
    Left = Val(gCD.LeerIni(sFFIni, "Ventana", "Left", CStr(Left)))
    Top = Val(gCD.LeerIni(sFFIni, "Ventana", "Top", CStr(Top)))
    Height = Val(gCD.LeerIni(sFFIni, "Ventana", "Height", CStr(Height)))
    Width = Val(gCD.LeerIni(sFFIni, "Ventana", "Width", CStr(Width)))
    WindowState = Val(gCD.LeerIni(sFFIni, "Ventana", "WindowState", CStr(WindowState)))
    
    MostrarLinea
    
    bIniciandose = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode <> vbFormCode Then
        iFFAccion = cFFAc_Cancelar
    End If
End Sub

Private Sub Form_Resize()
    'actualizar el tamaño del TextBox y los botones     (31/Ago/97)
    'si se minimiza no hacer nada
    If WindowState = vbMinimized Then Exit Sub
    
    With cmdAceptar
        .Top = ScaleHeight - 90 - .Height
        cmdCancelar.Top = .Top
        cmdImprimir.Top = .Top
        Label1.Top = .Top + 60
    End With
    With txtEditor
        .Width = ScaleWidth - 120
        .Height = cmdAceptar.Top - 90 - .Top
    End With
    GuardarTamaño
End Sub

Private Sub Form_Unload(Cancel As Integer)
    GuardarTamaño
    Set fMiniEditor = Nothing
End Sub

Private Sub mnuEd_Click()
    'Llama al procedimiento genérico de edición     (31/Ago/97)
    menuEdi
End Sub

Private Sub mnuEdicion_Click(Index As Integer)
    'Procedimiento genérico de los comandos de edición  (31/Ago/97)
    menuEdicion Index
End Sub

Private Sub GuardarTamaño()
    If bIniciandose = False Then
        'Guardar la posición y tamaño
        If WindowState <> vbMaximized Then
            gCD.GuardarIni sFFIni, "Ventana", "Left", CStr(Left)
            gCD.GuardarIni sFFIni, "Ventana", "Top", CStr(Top)
            gCD.GuardarIni sFFIni, "Ventana", "Height", CStr(Height)
            gCD.GuardarIni sFFIni, "Ventana", "Width", CStr(Width)
        End If
        gCD.GuardarIni sFFIni, "Ventana", "WindowState", CStr(WindowState)
    End If
End Sub

Private Sub txtEditor_Click()
    MostrarLinea
End Sub

Private Sub txtEditor_KeyUp(KeyCode As Integer, Shift As Integer)
    MostrarLinea
End Sub

Private Sub MostrarLinea()
    Dim TotalLineas&
    Dim LineaActual&
    Const EM_GETLINECOUNT = &HBA
    Const EM_LINEFROMCHAR = &HC9
    
    TotalLineas = SendMessage(txtEditor.hWnd, EM_GETLINECOUNT, 0, 0&)
    LineaActual = SendMessage(txtEditor.hWnd, EM_LINEFROMCHAR, -1, 0&) + 1
    Label1 = "Línea: " & LineaActual & " / " & TotalLineas
End Sub

Private Sub txtEditor2_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    'Aceptar archivos dejados
    'deben estar estas propiedades del TextBox:
    '   .OLEDragMode = 0
    '   .OLEDropMode = 1
    '
    Dim nFic As Integer
    Dim sNombre As String
    
    On Local Error Resume Next
    
    sNombre = Data.Files.Item(1)
    
    nFic = FreeFile
    Open sNombre For Input As nFic
    txtEditor = Input$(LOF(nFic), nFic)
    Close nFic
    
    Err = 0
    On Local Error GoTo 0
End Sub

Private Sub txtEditor_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    'Aceptar archivos dejados
    'deben estar estas propiedades del TextBox:
    '   .OLEDragMode = 0
    '   .OLEDropMode = 1
    '
    Dim nFic As Integer
    Dim sNombre As String
    
    On Local Error Resume Next
    
    sNombre = Data.Files.Item(1)
    
    nFic = FreeFile
    Open sNombre For Input As nFic
    txtEditor = Input$(LOF(nFic), nFic)
    Close nFic
    
    Err = 0
    On Local Error GoTo 0

End Sub

frmCampos (seleccionar el orden en que se mostrarán los datos)


'------------------------------------------------------------------------------
' Form para seleccionar los campos                                  (26/Abr/97)
'
' Revisado: 01/Oct/2001
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit
Option Compare Text

Private CopiaCampos() As Campo_t
Private Sub cmdAdd_Click()
    'Añadir el campo seleccionado
    Dim sTmp As String, sCampo As String
    Dim i As Long, j As Long
    
    sTmp = Trim$(Text1)
    If Len(sTmp) Then
        If Right$(sTmp, 1) <> "," Then
            sTmp = sTmp & ","
        End If
    End If
    With List1
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                sCampo = .List(i)
                'Sólo añadirlo, si no está...
                If InStr(sTmp, sCampo) = 0 Then
                    sTmp = sTmp & sCampo & ","
                End If
            End If
        Next
    End With
    sTmp = Trim$(sTmp)
    If Len(sTmp) Then
        If Right$(sTmp, 1) = "," Then
            sTmp = Left$(sTmp, Len(sTmp) - 1)
        End If
    End If
    Text1 = Trim$(sTmp)
End Sub

Private Sub cmdCancelar_Click()
    ' Si se cancela, no tener en cuenta los cambios                 (01/Oct/01)
    Dim i As Long
    '
    For i = 0 To NumCampos
        LSet Campos(i) = CopiaCampos(i)
    Next
    Hide
End Sub

Private Sub cmdCerrar_Click()
    Hide
End Sub

Private Sub Form_Load()
    ' añadir los campos a la lista
    Dim i As Long
    
    ReDim CopiaCampos(NumCampos)
    '
    With List1
        For i = 0 To NumCampos
            .AddItem Campos(i).Nombre
            ' Hacer una copia del campo
            LSet CopiaCampos(i) = Campos(i)
        Next
    End With
    Text1 = Campos(0).Nombre
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    ' Si se cancela pulsando en el botón cerrar (x)                 (01/Oct/01)
    ' No tener en cuenta los cambios
    Dim i As Long
    '
    If UnloadMode <> vbFormCode Then
        For i = 0 To NumCampos
            LSet Campos(i) = CopiaCampos(i)
        Next
    End If
End Sub


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

gsDBR (cuadro de diálogo para realizar búsquedas / reemplazos)


'------------------------------------------------------------------------------
' Form genérico para diálogo Buscar/Reemplazar
'
' Nuevas opciones:  06/Sep/97   Palabra completa y dirección
' Revisión:         02/Abr/98   Búsqueda en los combos mientras se escribe
'
' ©Guillermo 'guille' Som, 1996-2001
'------------------------------------------------------------------------------
Option Explicit

Const NumeroMaximoDeItems = 200
Dim bBuscandoEnCombo As Boolean
Dim iPosCombo As Integer



Private Sub cmdCancel_Click()
    ActualizarCombo
    
    iFFAccion = cFFAc_Cancelar
    Unload Me
End Sub

Private Sub cmdFindNext_Click()
    ActualizarCombo
    sFFBuscar = txtFind.Text
    sFFPoner = ""
    
    iFFAccion = cFFAc_BuscarSiguiente
    Unload Me
End Sub

Private Sub cmdReplace_Click()
    ActualizarCombo
    sFFBuscar = txtFind.Text
    sFFPoner = txtReplace.Text
    If Len(sFFPoner) = 0 Then
        iFFAccion = cFFAc_Buscar
    Else
        iFFAccion = cFFAc_Reemplazar
    End If
    Unload Me
End Sub

Private Sub cmdReplaceAll_Click()
    ActualizarCombo
    sFFBuscar = txtFind.Text
    sFFPoner = txtReplace.Text
    If Len(sFFPoner) = 0 Then
        iFFAccion = cFFAc_Buscar
    Else
        iFFAccion = cFFAc_ReemplazarTodo
    End If
    Unload Me
End Sub


Private Sub Combo1_Change(Index As Integer)
    Static YaEstoy As Boolean
    
    If bBuscandoEnCombo Then Exit Sub

    On Local Error Resume Next

    If Not YaEstoy Then
        YaEstoy = True
        unCombo_Change Combo1(Index).Text, Combo1(Index)
        YaEstoy = False
    End If
    
    If Index = 0 Then
        txtFind = Combo1(0).Text
    Else
        txtReplace = Combo1(1).Text
    End If
    
    Err = 0
End Sub

Private Sub Combo1_Click(Index As Integer)
    
    If bBuscandoEnCombo Then Exit Sub
    
    If Combo1(Index).ListIndex Then
        Combo1(Index).Text = Combo1(Index).List(Combo1(Index).ListIndex)
    End If
    If Index = 0 Then
        txtFind = Combo1(Index).Text
    Else
        txtReplace = Combo1(Index).Text
    End If
End Sub


Private Sub Combo1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    unCombo_KeyDown KeyCode
End Sub

Private Sub Combo1_KeyPress(Index As Integer, KeyAscii As Integer)
    unCombo_KeyPress KeyAscii
End Sub


Private Sub Form_Load()
    
    If sFFIni = "" Then
        sFFIni = "BuscReemp.ini"
    End If
    'Posicionar en el centro de la ventana principal
    Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
    
    'En un sub, para que acepte el tag de los combos.
    'Si se dejaba en el Form_Load, no se actualizaban los valores de inicio
    Timer1.Interval = 100
    Timer1.Enabled = True
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    'Si se cierra por el controlbox, o cualquier forma distinta del propio código,
    'asumir que se ha cancelado.
    If UnloadMode <> vbFormCode Then
        iFFAccion = cFFAc_Cancelar
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim n As Integer
    Dim vTmp As String
    Dim sTmp As String
    Dim i As Integer
    Dim j As Integer
    Dim sTag As String
    
    iFFCompleta = chkCompleta.Value
    iFFAtras = chkDireccion.Value
    
    If iFFAccion <> cFFAc_Cancelar Then
        ActualizarCombo
        For i = 0 To 1
            n = Combo1(i).ListCount
            sTag = Trim$(Combo1(i).Tag)
            If n > NumeroMaximoDeItems Then n = NumeroMaximoDeItems
            gCD.GuardarIni sFFIni, sTag, "NumEntradas", CStr(n)
            For j = 0 To n - 1
                vTmp = "Entrada" & CStr(j)
                sTmp = Combo1(i).List(j)
                gCD.GuardarIni sFFIni, sTag, vTmp, sTmp
            Next
        Next
    End If
    Set gsDBR = Nothing
End Sub

Private Sub ActualizarCombo()
    '-----------------------------------------------------
    'Esta rutina actualiza el contenido de los dos combos,
    'si la entrada en el Combo.Text no está, la incluye.
    'Se podría usar la llamada al API de Windows.
    '-----------------------------------------------------
    'Actualizar el contenido del Combo
    Dim sTmp As String
    'Para más rapidez...
    'Static i As Integer
    'Static j As Integer
    'Static hallado As Boolean
    Static k As Integer
    '
    bBuscandoEnCombo = True
    For k = 0 To 1
        'hallado = False
        sTmp = Combo1(k).Text
        If Len(Trim$(sTmp)) Then
            'j = Combo1(k).ListCount - 1
            'For i = 0 To j
            '    If StrComp(Trim$(sTmp), Trim$(Combo1(k).List(i))) = 0 Then
            '        hallado = True
            '        Exit For
            '    End If
            'Next
            'El valor devuelto no nos interesa
            If ActualizarLista(sTmp, Combo1(k)) Then
            End If
            'If Not hallado Then
            '    Combo1(k).AddItem sTmp, 0
            'End If
        End If
    Next
    bBuscandoEnCombo = False
End Sub

Private Sub IniciarCombo()
    Dim j As Integer
    Dim i As Integer
    Dim n As Integer
    Dim vTmp As String
    Dim sTmp As String
    Dim sTag As String
    
    'asignar los valores anteriores del combo
    For i = 0 To 1
        sTag = Trim$(Combo1(i).Tag)
        n = 0
        n = gCD.LeerIni(sFFIni, sTag, "NumEntradas", n)
        If n > NumeroMaximoDeItems Then n = NumeroMaximoDeItems
        '
        For j = 0 To n - 1
            vTmp = "Entrada" & CStr(j)
            sTmp = gCD.LeerIni(sFFIni, sTag, vTmp, "")
            If Len(sTmp) Then
                Combo1(i).AddItem sTmp
            End If
        Next
        ' Para que se muestre el texto que se introdujo.            (19/Ago/99)
        ' En algunos casos se borraba el texto a buscar...
        If i = 0 Then
            With Combo1(0)
                .Text = txtFind
                ' Seleccionar el texto
                If .Visible Then
                    .SelStart = 0
                    .SelLength = Len(.Text)
                End If
            End With
        Else
            With Combo1(1)
                .Text = txtReplace
                If .Visible Then
                    .SelStart = 0
                    .SelLength = Len(.Text)
                End If
            End With
        End If
    Next
End Sub

Private Sub Timer1_Timer()
    'asignar los valores anteriores del combo
    Timer1.Enabled = False  'Ya no necesitaremos más este evento!!!
    IniciarCombo
End Sub


Public Sub PosicionarControles()
    
    '==============================================================
    '--------------------------------------------------------------
    'Si se quiere ajustar el tamaño y posición del form ( 6/Sep/97)
    'comentar el Exit Sub
    '--------------------------------------------------------------
    Exit Sub
    '==============================================================
    
    'Posiciona los controles según su estado de visibilidad
    Dim tTop As Integer
    
    'Si se muestra Reemplazar
    tTop = Combo1(0).Top
    With Combo1(1)
        If .Enabled Then
            tTop = .Top
        End If
    End With
    'Se usa enabled en lugar de visible porque los controles
    'no son visibles hasta que se hace el Show del Form
    If chkCompleta.Enabled Then
        chkCompleta.Top = tTop + 510
        tTop = chkCompleta.Top - 150
    End If
    If chkDireccion.Enabled Then
        chkDireccion.Top = tTop + 510
        tTop = chkDireccion.Top
    End If
    cmdFindNext.Top = tTop + 480
    tTop = cmdFindNext.Top
    cmdReplace.Top = tTop
    cmdReplaceAll.Top = tTop
    cmdCancel.Top = tTop
    'Altura del Form
    Height = tTop + 810
End Sub

gsQBE (formulario para realizar consultas)


'------------------------------------------------------------------------------
' gsQBE  Form para realizar las consultas
'
' Revisado para usar con ADO                                        (01/Oct/01)
'
' ©Guillermo 'guille' Som, 1994-2001
'------------------------------------------------------------------------------
Option Explicit
Option Compare Text

Dim nOpciones As Long               ' Número de Opciones para la búsqueda y mostrar
Dim MaxCampos As Long
Dim ComparaOr() As String

Private Sub Command1_Click()
    'Preparado el proceso de búsqueda: 1/Dic/94
    Dim sBuscar As String
    Dim flag As Boolean
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim sTmp As String
    Dim sTmp2 As String
    Dim q As Integer
    Dim p As Integer
    Dim sLogico As String
    
    'Ahora si en Text1(), se escribe | (AltGr+1),
    'o [O] se hará una comparación OR
    'y si se empieza con [O] se hace un OR con el
    'siguiente campo en vez de un AND   (25/Nov/95)
    
    On Local Error Resume Next

    '---Asignar a sBuscar los campos y valores de la búsqueda.
    sBuscar = ""
    For i = 0 To nOpciones
        k = CboCampos(i).ListIndex - 1
        If k >= 0 Then
            If cboComparación(i).ListIndex < 0 Then
                cboComparación(i).ListIndex = 0
            End If
            j = cboComparación(i).ListIndex
            'Comprobar si tiene |
            sTmp = Trim$(Text1(i).Text)
            sLogico = "AND "
            'Se admite [O] y [O]
            If Left$(sTmp, 2) = "[O" Then
                q = InStr(sTmp, "]")
                If q = 0 Then q = 2
                sLogico = "OR  "
                sTmp = Mid$(sTmp, q + 1)
            End If
            'Separar en el mísmo texto con | o [O]
            q = InStr(sTmp, "|")
            If q = 0 Then
                q = InStr(sTmp, "[O")
            End If
            p = 0
            If q Then
                ExtraeOpciones sTmp, q
                p = q
            End If
            If p Then
                sTmp = ""
                For q = 1 To p - 1
                    'Arreglar esto...
                    Select Case Campos(k).Tipo
                    Case dbByte, dbText, dbMemo
                        sTmp = sTmp & ComparaOr(q) & "%' OR " & Campos(k).Nombre & " " & cboComparación(i).List(j) & " '%"
                    Case dbDate
                        sTmp = sTmp & ComparaOr(q) & "') OR " & Campos(k).Nombre & " " & cboComparación(i).List(j) & " Datevalue('"
                    Case Else
                        sTmp = sTmp & ComparaOr(q) & " OR " & Campos(k).Nombre & " " & cboComparación(i).List(j) & " "
                    End Select
                Next
                sTmp = sTmp & ComparaOr(p)
            End If
            Select Case Campos(k).Tipo
            Case dbByte, dbText, dbMemo
                'poner '% ... %' si es Like o Not Like
                If InStr(cboComparación(i).List(j), "Like") Then
                    sBuscar = sBuscar & Campos(k).Nombre & " " & cboComparación(i).List(j) & " '%" & CStr(sTmp) & "%' " & sLogico
                Else
                    'sólo poner '...' por si se quiere una coincidencia exacta
                    sBuscar = sBuscar & Campos(k).Nombre & " " & cboComparación(i).List(j) & " '" & CStr(sTmp) & "' " & sLogico
                End If
            Case dbDate                 'poner datevalue('...')
                sBuscar = sBuscar & " " & Campos(k).Nombre & " " & cboComparación(i).List(j) & " Datevalue('" & sTmp & "') " & sLogico
            Case Else                   'no poner '% ... %'
                sBuscar = sBuscar & Campos(k).Nombre & " " & cboComparación(i).List(j) & " " & sTmp & " " & sLogico
            End Select
            flag = True
        End If
    Next
    If Not flag Then
        Beep
        MsgBox "Se debería seleccionar por lo menos un campo." & Chr$(13) & "Si lo que pretendes es cancelar la búsqueda, pulsa en el botón de Cancelar.", 64
        Exit Sub
    End If
    'Quitarle el final
    sBuscar = Left$(sBuscar, Len(sBuscar) - 4)

    'Guardar la selección en el fichero INI
    GuardarQBE
    'Procesar los datos de la consulta
    ProcesarConsulta sBuscar
End Sub

Private Sub Command2_Click()
    ' Salir
    MostrarConsulta!Command1.Caption = ""
    Unload Me
End Sub

Private Sub Command3_Click()
    '----------------------------------------------
    ' Consulta directa
    '----------------------------------------------
    sFFPoner = Trim$(gCD.LeerIni(sFicIni, "General", "Buscar", ""))
    gsPedirUnValor "Consulta directa", "Escribe el CAMPO y la comparación a usar. Ejemplo: Población LIKE '%Nerja%'", "", sFFPoner, "Aceptar"
    If iFFAccion <> cFFAc_Cancelar Then
        If Len(sFFPoner) Then
            gCD.GuardarIni sFicIni, "General", "Buscar", sFFPoner
            ProcesarConsulta sFFPoner
        End If
    Else
        MostrarConsulta!Command1.Caption = ""
    End If
End Sub

Private Sub ExtraeOpciones(sTmp As String, q As Integer)
    Dim p As Integer
    Dim sTmp2 As String
    Dim i As Integer
    
    sTmp2 = sTmp
    p = 0
    Do
        q = InStr(sTmp, "|")
        If q Then
            sTmp = Mid$(sTmp, q + 1)
            p = p + 1
        Else
            'Buscar también [O
            q = InStr(sTmp, "[O")
            If q Then
                i = InStr(sTmp, "]")
                If i = 0 Then q = q + 1
                sTmp = Mid$(sTmp, q + 1)
                p = p + 1
            End If
        End If
    Loop While q
    If Len(Trim$(sTmp)) Then
        p = p + 1
    End If

    sTmp = sTmp2
    ReDim ComparaOr(p) As String
    p = 0
    Do
        q = InStr(sTmp, "|")
        If q Then
            p = p + 1
            ComparaOr(p) = Left$(sTmp, q - 1)
            sTmp = Mid$(sTmp, q + 1)
        Else
            q = InStr(sTmp, "[O")
            If q Then
                ComparaOr(p) = Left$(sTmp, q - 1)
                i = InStr(sTmp, "]")
                If i = 0 Then q = q + 1
                sTmp = Mid$(sTmp, q + 1)
                p = p + 1
            End If
        End If
    Loop While q
    If Len(Trim$(sTmp)) Then
        p = p + 1
        ComparaOr(p) = sTmp
    End If
    q = p

End Sub

Private Sub Form_Load()
    Dim i As Integer
    Dim j As Integer
    Dim t As Integer
    Dim dBase2
    Dim sTmp As String
    
    MaxCampos = UBound(Campos)
    
    Screen.MousePointer = vbHourglass
    
    Top = 0
    Left = 0
    'MostrarProgress "Asignando la ventana para la consulta a mostrar... " & vbCrLf
    
    'Ahora siempre se usan Combos para seleccionar los campos
    'ya que permiten hacer múltiples comparaciones (24/Nov/95)
    nOpciones = 11
    Height = 1510 + (nOpciones * 430)

    'Cargar los nombres de los campos...
    With cboComparación(0)
        .Clear
        .AddItem "Like"
        .AddItem "Not Like"
        .AddItem "<"
        .AddItem ">"
        .AddItem "<="           ' Ponía =<                          (08/Oct/01)
        .AddItem ">="
        .AddItem "="
        .AddItem "<>"
    End With
    
    CboCampos(0).AddItem "Ninguno"
    CboMostrar(0).AddItem "No Mostrar"
    For i = 0 To MaxCampos
        With Campos(i)
           CboCampos(0).AddItem .Nombre
           CboMostrar(0).AddItem .Nombre
        End With
    Next
    Text1(0).Text = ""
    
    CboCampos(0).Top = cboComparación(0).Top
    CboCampos(0).Visible = True
    CboMostrar(0).Top = cboComparación(0).Top
    CboMostrar(0).Visible = True
    For i = 1 To nOpciones
        Load cboComparación(i)
        Load Text1(i)
        Load CboCampos(i)
        Load CboMostrar(i)
        For j = 0 To cboComparación(0).ListCount - 1
            cboComparación(i).AddItem cboComparación(0).List(j)
        Next
        For j = 0 To CboCampos(0).ListCount - 1
            CboCampos(i).AddItem CboCampos(0).List(j)
            CboMostrar(i).AddItem CboMostrar(0).List(j)
        Next
        cboComparación(i).Top = cboComparación(i - 1).Top + cboComparación(i - 1).Height + 75
        cboComparación(i).Visible = True
        CboCampos(i).Top = cboComparación(i).Top
        CboCampos(i).Visible = True
        CboMostrar(i).Top = cboComparación(i).Top
        CboMostrar(i).Visible = True
        Text1(i).Top = cboComparación(i).Top
        Text1(i).Visible = True
        Text1(i).Text = ""
    Next
    ' Poder recuperar la última consulta...
    For i = 0 To nOpciones
        sTmp = "OpCampo" & RTrim$(Str$(i))
        CboCampos(i).ListIndex = gCD.LeerIni(sFicIni, "QBE_" & sUsuario, sTmp, 0)
        sTmp = "OpComparacion" & RTrim$(Str$(i))
        cboComparación(i).ListIndex = gCD.LeerIni(sFicIni, "QBE_" & sUsuario, sTmp, 0)
        sTmp = "OpTexto" & RTrim$(Str$(i))
        Text1(i).Text = gCD.LeerIni(sFicIni, "QBE_" & sUsuario, sTmp, "")
        sTmp = "OpMostrar" & RTrim$(Str$(i))
        CboMostrar(i).ListIndex = gCD.LeerIni(sFicIni, "QBE_" & sUsuario, sTmp, 0)
    Next
    ' Poner en orden las tabulaciones...
    ' Arreglado correctamente                                       (14/Oct/01)
    Command3.TabIndex = 0
    Command2.TabIndex = 0
    Command1.TabIndex = 0
    For i = nOpciones To 0 Step -1
        CboMostrar(i).TabIndex = 0
        Text1(i).TabIndex = 0
        cboComparación(i).TabIndex = 0
        CboCampos(i).TabIndex = 0
    Next
    
    Command1.Top = ScaleHeight - 510
    Command2.Top = Command1.Top
    Command3.Top = Command1.Top
    Label1(4).Top = Command1.Top + 45

    Screen.MousePointer = vbDefault
End Sub


Private Sub GuardarQBE()
    Dim i As Integer
    Dim sValor As String
    Dim sTmp As String
    
    'Guardar la última consulta...
    
    For i = 0 To nOpciones
        sTmp = "OpCampo" & RTrim$(Str$(i))
        sValor = Str$(CboCampos(i).ListIndex)
        gCD.GuardarIni sFicIni, "QBE_" & sUsuario, sTmp, sValor
        
        sTmp = "OpComparacion" & RTrim$(Str$(i))
        sValor = Str$(cboComparación(i).ListIndex)
        gCD.GuardarIni sFicIni, "QBE_" & sUsuario, sTmp, sValor
        
        sTmp = "OpTexto" & RTrim$(Str$(i))
        sValor = Text1(i).Text
        gCD.GuardarIni sFicIni, "QBE_" & sUsuario, sTmp, sValor
        
        sTmp = "OpMostrar" & RTrim$(Str$(i))
        sValor = Str$(CboMostrar(i).ListIndex)
        gCD.GuardarIni sFicIni, "QBE_" & sUsuario, sTmp, sValor
    Next
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    ' Si se cierra desde la "x", no mostrar la consulta             (10/Ago/00)
    If UnloadMode = vbFormControlMenu Then
        MostrarConsulta!Command1.Caption = ""
    End If
End Sub

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

Private Sub Label1_Click(Index As Integer)
    Dim Msg As String

    If Index = 4 Then
        If Text2.Visible Then
            Text2.Visible = False
            Text2.Text = ""
            Command1.Visible = True
            Command2.Visible = True
            Command3.Visible = True
            Label1(4).Caption = " Pulsa aquí, para mostrar la ventana de ayuda "
        Else
            Msg = "CONSEJOS PARA USAR LA OPCIÓN DE BÚSQUEDA" & vbCrLf & vbCrLf
            Msg = Msg & "Selecciona los campos de búsqueda, la comparación, "
            Msg = Msg & "el texto a comparar y los campos que quieres mostrar." & vbCrLf
            Msg = Msg & "Por defecto se hace una búsqueda selectiva, es decir deben coincidir "
            Msg = Msg & "todos los campos especificados con la comparación que se hace." & vbCrLf
            Msg = Msg & "Aunque se puede hacer una búsqueda opcional, (no selectiva): "
            Msg = Msg & "no tienen porqué coincidir todos los campos, sino que se puede "
            Msg = Msg & "buscar por conceptos distintos, más abajo hay varios ejemplos." & vbCrLf
            Msg = Msg & "Las comparaciones que se pueden hacer son: " & vbCrLf
            Msg = Msg & "    LIKE   Igual" & vbCrLf
            Msg = Msg & "NOT LIKE   Distinto (no igual)" & vbCrLf
            Msg = Msg & "       >   Mayor" & vbCrLf
            Msg = Msg & "       <   Menor" & vbCrLf
            Msg = Msg & "      >=   Mayor o igual" & vbCrLf
            Msg = Msg & "      <=   Menor o igual" & vbCrLf
            Msg = Msg & "       =   Igual" & vbCrLf
            Msg = Msg & "      <>   Distinto" & vbCrLf
            Msg = Msg & "La diferencia entre 'LIKE'/'NOT LIKE' y '='/'<>' "
            Msg = Msg & "es que con los LIKE se pueden usar los comodines: % _ #" & vbCrLf
            Msg = Msg & "-- _ un caracter cualquiera" & vbCrLf
            Msg = Msg & "-- # un dígito (número)" & vbCrLf
            Msg = Msg & "-- % cualquier cantidad de caracteres" & vbCrLf
            Msg = Msg & "Ejemplos:" & vbCrLf
            Msg = Msg & "-- M% todos los registros que en el campo especificado, empiecen por M" & vbCrLf
            Msg = Msg & "-- %M% que tenga una M" & vbCrLf
            Msg = Msg & "-- A_C cualquier secuencia que empiece con A y termine con C: ABC, AAC, etc." & vbCrLf
            Msg = Msg & vbCrLf & "IMPORTANTE: Por defecto, para los campos de texto, lo que se escriba en la casilla "
            Msg = Msg & "del texto a buscar, se pone entre dos %, de esta forma se buscará "
            Msg = Msg & "cualquier registro que tenga ese texto escrito; por tanto el uso del "
            Msg = Msg & "comodín % no tiene actualmente ningún significado, en el futuro "
            Msg = Msg & "es posible que haya que expecificarlo, pero por ahora no es necesario." & vbCrLf & vbCrLf
            Msg = Msg & "En CONSULTA DIRECTA si se puede especificar este comodín, (más abajo se explica como usar la Consulta Directa)." & vbCrLf & vbCrLf
            Msg = Msg & "En una misma casilla de texto, se pueden especificar varias palabras, "
            Msg = Msg & "separando cada palabra con: " & vbCrLf
            Msg = Msg & "| (AltGr+1) o con [O]" & vbCrLf
            Msg = Msg & "Ejemplo: para buscar la palabra CASA o CHALET, escribiríamos: "
            Msg = Msg & "CASA|CHALET o bien CASA[O]CHALET" & vbCrLf
            Msg = Msg & "Veamos varios ejemplos:" & vbCrLf
            Msg = Msg & "Buscar las fechas iguales a 4/11/95 o 7/11/95" & vbCrLf
            Msg = Msg & " COMPARACIÓN       TEXTO" & vbCrLf
            Msg = Msg & "    =              04/11/95|07/11/95" & vbCrLf
            Msg = Msg & "Buscar las fechas mayores al 10/11/95" & vbCrLf
            Msg = Msg & "    >              10/11/95" & vbCrLf
            Msg = Msg & "Cuidado cuando se especifican varias comparaciones ya "
            Msg = Msg & "que puede que se pidan cosas imposibles:" & vbCrLf
            Msg = Msg & "Si estos dos ejemplos se especifican en la mísma "
            Msg = Msg & "búsqueda, no mostraría nada, ya que se le dice:" & vbCrLf
            Msg = Msg & "   Todas las fechas que sean iguales al 4 de nov" & vbCrLf
            Msg = Msg & "   'O' iguales al 7 de nov" & vbCrLf
            Msg = Msg & "   'Y' que sean mayores al 10 de nov" & vbCrLf
            Msg = Msg & "la verdad es que no se cumpliría esa comparación, "
            Msg = Msg & "ya que no puede ser igual al 4 nov y también mayor que el 10 nov." & vbCrLf
            Msg = Msg & "El error está en pensar que se haría de esta forma:" & vbCrLf
            Msg = Msg & "   Todas las fechas que sean iguales al 4 de nov" & vbCrLf
            Msg = Msg & "   'O' iguales al 7 de nov" & vbCrLf
            Msg = Msg & "   'Y' LAS que sean mayores al 10 de nov" & vbCrLf & vbCrLf
            Msg = Msg & "Es importante tener en cuenta, como apunté al principio, que siempre que se "
            Msg = Msg & "comparan varios campos (o uno en distintas "
            Msg = Msg & "líneas) se hace un 'Y', es decir que se tienen que "
            Msg = Msg & "cumplir todas las comparaciones, (comparación selectiva)." & vbCrLf
            Msg = Msg & "Para cambiar el 'Y'  por un 'O' (comparación opcional), "
            Msg = Msg & "escribir [O] en el campo anterior al que se quiere aplicar." & vbCrLf
            Msg = Msg & "En el ejemplo anterior, escribiríamos en el primer campo:" & vbCrLf
            Msg = Msg & " COMPARACIÓN       TEXTO" & vbCrLf
            Msg = Msg & " =                 [O]04/11/95|07/11/95" & vbCrLf
            Msg = Msg & "en el segundo:" & vbCrLf
            Msg = Msg & " >                 10/11/95" & vbCrLf
            Msg = Msg & "Se mostrarían todas las fechas:" & vbCrLf
            Msg = Msg & "   iguales al  4 nov" & vbCrLf
            Msg = Msg & "   'O' igual al  7 nov" & vbCrLf
            Msg = Msg & "   'O' mayor al 10 nov" & vbCrLf
            Msg = Msg & "NOTA: Cuando se usan fechas, hay que tener en cuenta el formato usado, es decir si se deben especificar o no los ceros delante de los números. Por regla general, deben especificarse." & vbCrLf
            Msg = Msg & "En caso de textos:" & vbCrLf
            Msg = Msg & "Buscar todos los JUAN 'O' los que viven en NERJA" & vbCrLf
            Msg = Msg & "  CAMPO          COMPARACIÓN     TEXTO" & vbCrLf
            Msg = Msg & "  Nombre         Like            [O]Juan" & vbCrLf
            Msg = Msg & "  Población      Like            Nerja" & vbCrLf & vbCrLf
            Msg = Msg & "COMO USAR LA CONSULTA DIRECTA:" & vbCrLf
            Msg = Msg & "En la consulta directa se debe especificar el o los campos a comparar y la comparación a realizar: " & vbCrLf
            Msg = Msg & "Para eso es necesario saber como se llama el campo que se quiere comparar, "
            Msg = Msg & "la lista de los nombres de los campos sale en la ventana de la opción de configuración, "
            Msg = Msg & "por defecto las etiquetas informativas de la pantalla principal o las listas de los nombres "
            Msg = Msg & "de los campos que aparecen en esta opción de búsqueda, son los nombres de "
            Msg = Msg & "los campos, salvo que se hayan cambiado con la opción de Configuración." & vbCrLf
            Msg = Msg & "En la consulta directa no se permite usar | ni [O]" & vbCrLf
            Msg = Msg & "Ejemplo: Buscar todos los JUAN 'O' los que viven en NERJA" & vbCrLf
            Msg = Msg & "Se hará de esta forma:" & vbCrLf
            Msg = Msg & "Nombre LIKE '%Juan%' OR [Población] LIKE '%Nerja%'" & vbCrLf
            Msg = Msg & "Para buscar todos los registros que en el campo Nombre tengan Juan "
            Msg = Msg & "y la Fecha sea superior al 10/11/95:" & vbCrLf
            Msg = Msg & "Nombre LIKE '%Juan%' OR Fecha > DATEVALUE('10/11/95')" & vbCrLf
            Msg = Msg & "Como se puede ver, la Consulta Directa es más complicada de usar y está "
            Msg = Msg & "sólo para usarla si se sabe lo que se quiere hacer o para especificar otras "
            Msg = Msg & "opciones que no están contempladas en la búsqueda normal." & vbCrLf
            Msg = Msg & "El lenguaje que se usa es SQL (Structured Query Lenguage) "
            Msg = Msg & "y la instrucción que se hace es:" & vbCrLf
            Msg = Msg & "SELECT * FROM " & sTabla & " WHERE <búsqueda> ORDER BY c1ID" & vbCrLf
            Msg = Msg & "<búsqueda> es el texto que se escribe." & vbCrLf
            Msg = Msg & "Los datos mostrados, serán los que se especifiquen en los campos a mostrar, al igual que en la consulta normal." & vbCrLf & vbCrLf
            Msg = Msg & "IMPORTANTE: En estas rutinas de búsqueda no se hace distinción entre mayúsculas y minúsculas."
            Msg = Msg & vbCrLf & vbCrLf & "[FIN DEL MENSAJE DE AYUDA]"
            
            'If MsgConfirm(Msg) Then
            'End If
            'MsgBox Msg
            With Text2
                '.Text = "<<>>" & vbCrLf & vbCrLf & Msg
                .Text = Msg
                .Move 0, 0, ScaleWidth, ScaleHeight - Label1(4).Height - 270
                .Visible = True
                Command1.Visible = False
                Command2.Visible = False
                Command3.Visible = False
                Label1(4).Caption = " Pulsa aquí para cerrar la ayuda "
            End With
            
            Msg = ""
        End If
    End If
End Sub

Private Sub ProcesarConsulta(sBuscar As String)
    Const cLongitudMaxima = 100
    Dim Db As ADODB.Connection  'Database
    Dim strCampos As String
    Dim SQLtmp As String
    Dim MySnap As Recordset
    Dim i As Integer
    Dim flag As Integer
    Dim k As Integer
    Dim iLongCampo As Integer
    Dim sTmp As String
    Dim j%
    '
    ReDim LongCampos(MaxCampos)
    ReDim LongMayor(MaxCampos)
    '
    Screen.MousePointer = vbHourglass
    '
    Load MostrarConsulta
    MostrarConsulta!Command1.Caption = ""
    MostrarConsulta!List1.Clear
    
    ' Este no cambiarlo, dejar el Resume Next
    On Local Error Resume Next
    
    ' Abrir la base...
    'Set Db = OpenDatabase(sBase)
    CrearConexion Db, True
    '
    ' Quitar los comodines antiguos de la cadena                    (01/Oct/01)
    sBuscar = Replace(sBuscar, "*", "%")
    sBuscar = Replace(sBuscar, "?", "_")
    '
    ' Ejecutar orden SQL con los datos solicitados
    SQLtmp = "select * from [" & sTabla & "] where " & sBuscar & " order by " & sClasif
    Set MySnap = Db.Execute(SQLtmp) ' Db.OpenRecordset(SQLtmp, dbOpenSnapshot)
    'MySnap.MoveFirst
    If MySnap.BOF And MySnap.EOF Then
        Set MySnap = Nothing
        Db.Close
        Set Db = Nothing
        '
        Err = 0
        ' no hay datos, avisar
        MsgBox "No hay datos que coincidan con la búsqueda especificada." & vbCrLf & SQLtmp, 64
        cboComparación(0).SetFocus
        Screen.MousePointer = vbDefault
        Exit Sub
    End If
    
    On Local Error GoTo HayError
    
    strCampos = ""
    'Añadir los nombres de los "campos" a mostrar
    For i = 0 To nOpciones
        k = CboMostrar(i).ListIndex
        If k >= 1 Then
            Select Case Campos(k - 1).Tipo
            Case dbText, dbMemo
                LongCampos(k - 1) = cLongitudMaxima
                If Campos(k - 1).Tamaño > 0 Then
                    If Campos(k - 1).Tamaño > cLongitudMaxima Then
                        LongCampos(k - 1) = cLongitudMaxima
                    End If
                End If
            Case Else
                LongCampos(k - 1) = 12
            End Select
            sTmp = Trim$(Campos(k - 1).Nombre)
            sTmp = Left$(sTmp & Space$(LongCampos(k - 1)), LongCampos(k - 1))
            'para el tamaño más largo de los mostrados (21/May/97)
            If Len(RTrim$(sTmp)) > LongMayor(k - 1) Then
                LongMayor(k - 1) = Len(RTrim$(sTmp))
                If LongMayor(k - 1) > LongCampos(k - 1) Then
                    LongMayor(k - 1) = LongCampos(k - 1)
                End If
            End If
            strCampos = strCampos & sTmp & ", "
        End If
    Next
    With MostrarConsulta
        .List1.AddItem strCampos
        .List1.ItemData(.List1.NewIndex) = -1
        .List1.AddItem String$(Len(strCampos), "-")
        .List1.ItemData(.List1.NewIndex) = -1
    End With
    flag = False
    MySnap.MoveFirst
    Do Until MySnap.EOF
        DoEvents
        strCampos = ""
        For i = 0 To nOpciones
            k = CboMostrar(i).ListIndex
            If k >= 1 Then
                flag = True
                iLongCampo = LongCampos(k - 1)
                sTmp = Left$(Trim$(MySnap(Campos(k - 1).Nombre) & " ") & Space$(iLongCampo), iLongCampo)
                If Err Then
                    sTmp = Left$("¡¡¡ERROR!!!" & Space$(iLongCampo), iLongCampo)
                    Err = 0
                End If
                'filtrar los vbCrLf
                If InStr(sTmp, vbCr) Then
                    sTmp = QuitarCaracter(sTmp, vbCr, " ")
                End If
                If InStr(sTmp, vbLf) Then
                    sTmp = QuitarCaracter(sTmp, vbLf, " ")
                End If
                'para el tamaño más largo de los mostrados (21/May/97)
                If Len(RTrim$(sTmp)) > LongMayor(k - 1) Then
                    LongMayor(k - 1) = Len(RTrim$(sTmp))
                End If
                strCampos = strCampos & sTmp & ", "
            End If
        Next
        MostrarConsulta!List1.AddItem strCampos
        MostrarConsulta!List1.ItemData(MostrarConsulta!List1.NewIndex) = MySnap("c1ID")
        MySnap.MoveNext
    Loop
    If Not flag Then
        'no hay datos, avisar
        MsgBox "No hay datos que coincidan con la búsqueda especificada.", 64
        cboComparación(0).SetFocus
        Screen.MousePointer = vbDefault
        Exit Sub
    Else
        'ajustar el ancho a la columna más grande
        'Repasar todos los items de MostrarConsulta!List1...
        With MostrarConsulta!List1
            For flag = 0 To .ListCount - 1
                sTmp = .List(flag)
                j = 0
                For i = 0 To nOpciones
                    k = CboMostrar(i).ListIndex
                    If k >= 1 Then
                        iLongCampo = LongCampos(k - 1)
                        If LongMayor(k - 1) < LongCampos(k - 1) Then
                            iLongCampo = LongMayor(k - 1)
                            sTmp = Left$(sTmp, j) & Mid$(sTmp, j + 1, iLongCampo) & Mid$(sTmp, j + 1 + LongCampos(k - 1))
                            .List(flag) = sTmp
                        End If
                        j = j + iLongCampo + 2
                    End If
                Next
            Next
        End With
    End If
    Screen.MousePointer = vbDefault
    MostrarConsulta!Command1.Caption = "Salir"
    Unload Me
    Exit Sub
HayError:
    'MsgBox "Error: " & CStr(Err) & " " & Error$
    Err = 0
    Resume Next
End Sub

Private Sub Text2_DblClick()
    ' Ocultarlo y vaciar el contenido del texto                     (10/Ago/00)
    Text2.Visible = False
    Text2.Text = ""
End Sub

Imprimir (Formulario para seleccionar la impresora a usar)


'------------------------------------------------------------------------------
' Diálogo para imprimir los datos...                                ( 9/Oct/96)
' Adaptado/simplificado para Imprimir normal                        ( 1/Sep/97)
'
' Revisado para usarlo en Windows NT/2000 (eso espero!)             (01/Oct/01)
'
' ©Guillermo 'guille' Som, 1996-2001
'------------------------------------------------------------------------------
Option Explicit
'
Dim bCambiandoCombo As Boolean
Dim ImpresoraActual As Long
'
Dim tOrientacion As Long         '(10/Sep/97)

Public sLpt As String

Private Sub cboImpresoras_Click()
    Dim tPrinter As Printer
    
    If bCambiandoCombo Then Exit Sub
    
    For Each tPrinter In Printers
        If tPrinter.DeviceName = CboImpresoras.Text Then
            Set Printer = tPrinter
            Exit For
        End If
    Next
    MostrarPortImpresora
End Sub

Private Sub cmdCancelar_Click()
    iFFAccion = cFFAc_Cancelar
    Unload Me
End Sub

Private Sub cmdAceptar_Click()
    iFFAccion = cFFAc_Aceptar
    Hide
End Sub

Private Sub chkOrientacion_Click()
    Dim i As Long
    
    For i = 0 To 1
        optOrientacion(i).Enabled = chkOrientacion
    Next
End Sub

Private Sub Form_Load()
    Dim e1 As Boolean
    
    iFFAccion = cFFAc_IDLE
    DoEvents
    '
    'Centrar el form
    Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
    '
    If OptMétodoImpresión(0) = 1 Then
        e1 = True
    Else
        e1 = False
    End If
    chkCourierNew.Enabled = e1
    '
    MostrarImpresoras
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode <> vbFormCode Then
        iFFAccion = cFFAc_Cancelar
    End If
End Sub

Private Sub MostrarPortImpresora()
    
    On Local Error Resume Next
    
'    sLpt = Printer.Port
'    If Right$(sLpt, 1) = ":" Then
'        sLpt = Left$(sLpt, Len(sLpt) - 1)
'    End If
'    '
'    Label3 = "Los datos se imprimirán en: " & sLpt
    '
    ' Primero se asignará el pruerto de la impresora                (01/Oct/01)
    ' Pero si no es LPT? se usará el Printer.DeviceName
    '
    sLpt = Printer.Port
    ' Si el puerto es LPTx: intentar usar ese puerto
    If Left$(sLpt, 3) = "LPT" And Len(sLpt) > 3 Then
        If Right$(sLpt, 1) = ":" Then
            sLpt = Left$(sLpt, Len(sLpt) - 1)
        End If
        '
    Else
        ' Usar el nombre de la impresora                            (04/Abr/00)
        sLpt = Printer.DeviceName
    End If
    Label3 = "Los datos se imprimirán en: " & sLpt
    '
    On Local Error GoTo 0
End Sub

Private Sub MostrarImpresoras()
    On Local Error Resume Next
    
    'Mostrar todas las impresoras instaladas
    '
    Dim tPrinter As Printer
    Dim i As Long
    
    
    bCambiandoCombo = True
    tOrientacion = 0
    
    CboImpresoras.Clear
    i = 0
    For Each tPrinter In Printers
        CboImpresoras.AddItem tPrinter.DeviceName
        i = i + 1
        If tPrinter.DeviceName = Printer.DeviceName Then
            ImpresoraActual = i
            tOrientacion = tPrinter.Orientation
        End If
    Next
    CboImpresoras.ListIndex = ImpresoraActual - 1
    If tOrientacion Then
        optOrientacion(tOrientacion - 1) = True
    End If
    bCambiandoCombo = False
    MostrarPortImpresora
    
    Err = 0
    On Local Error GoTo 0
End Sub

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

Private Sub OptMétodoImpresión_Click(Index As Integer)
    Dim e1 As Boolean
    Static YaEstoy As Boolean
    
    If YaEstoy Then Exit Sub
    
    YaEstoy = True
    If OptMétodoImpresión(0) Then
        e1 = True
    Else
        e1 = False
    End If
    chkCourierNew.Enabled = e1
    YaEstoy = False
End Sub

Private Sub optOrientacion_Click(Index As Integer)
    tOrientacion = Index + 1
End Sub

MostrarConsulta (formulario en el que se mostrará el resultado de la consulta realizada en gsQBE)


'------------------------------------------------------------------------------
' Para mostrar los datos de la consulta
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit

Private Sub CmdBuscar_Click()
    Hide
    gsQBE.Show vbModal
    If MostrarConsulta!Command1.Caption = "" Then
        Unload MostrarConsulta
    Else
        MostrarConsulta.Show
    End If
End Sub

Private Sub CmdEditar_Click()
    Dim registro As Long
    
    If List1.ListIndex < 0 Then 'No ha registro seleccionado
        MsgBox "Debes seleccionar de la lista el registro a mostrar.", 48
    Else
        registro = List1.ItemData(List1.ListIndex)
        If registro > 0 Then
            With elForm
                If .BuscarEnData(registro) Then  '.Data1.Find "ID = " & registro, 1
                'If .Data1.EOF Then
                    Beep
                    MsgBox "Ese registro no ha sido hallado " & registro
                '    .Data1.MoveFirst
                Else
                    .Show
                End If
            End With
            WindowState = vbMinimized
            'Unload Me
        End If
    End If
End Sub

Private Sub cmdImprimir_Click()
    Static EstaImprimiendo As Integer
    
    If EstaImprimiendo Then
        iFFAccion = cFFAc_Cancelar
        DoEvents
    Else
        iFFAccion = cFFAc_IDLE
        EstaImprimiendo = True
        Command1.Enabled = False
        CmdBuscar.Enabled = False
        CmdImprimir.Caption = "Imprimiendo..."
        
        gsImprimir List1
        
        EstaImprimiendo = False
    End If
    Command1.Enabled = True
    CmdBuscar.Enabled = True
    CmdImprimir.Caption = "Imprimir"
End Sub

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_Activate()
    Const LB_SETHORIZONTALEXTENT = &H400 + 21
    Const NULO = &O0
    Dim ListhWnd
    Dim ListLen
    Dim iTmp
    Dim ScaleTmp As Integer

    'Mostrar el número de datos hallados
    Caption = "Resultado de la búsqueda: " & List1.ListCount - 2 & " datos"
    'Poner un scroll horizontal al ListBox
    ScaleTmp = ScaleMode
    ListhWnd = List1.hWnd
    ScaleMode = 3
    ListLen = 4000
    iTmp = SendMessage(ListhWnd, LB_SETHORIZONTALEXTENT, ListLen, NULO)
    ScaleMode = ScaleTmp
End Sub

Private Sub Form_Load()
    'Posicionarla en la parte superior izquierda
    Top = 0
    Left = 0

End Sub

Private Sub Form_Resize()
    If WindowState <> 1 Then
        Command1.Top = ScaleHeight - Command1.Height - 120
        CmdImprimir.Top = Command1.Top
        CmdBuscar.Top = Command1.Top
        CmdEditar.Top = Command1.Top
        List1.Move 90, 90, ScaleWidth - 180, Command1.Top - 180
    End If
End Sub

Private Sub List1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    'si se pulsa con el botón derecho...
    If Button = 2 Then
        'mostrar pop-up menú
        If HaySeleccion(List1) Then
            PopupMenu mnuEdit, , , , mnuCopiar
        Else
            PopupMenu mnuEdit, , , , mnuCopiarTodos
        End If
    End If
End Sub

Private Function HaySeleccion(queList As Control) As Boolean
    'Comprobar si hay algún item seleccionado
    Dim i&
    
    HaySeleccion = False
    With queList
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                HaySeleccion = True
                Exit For
            End If
        Next
    End With
End Function

Private Sub CopiarList(ByVal bModo As Boolean)
    'Copiar en el clipboard los elementos de la lista
    Dim sTmp$
    Dim i&
    
    sTmp = ""
    With List1
        For i = 0 To .ListCount - 1
            If bModo Then
                If .Selected(i) Then
                    sTmp = sTmp & .List(i) & vbCrLf
                End If
            Else
                sTmp = sTmp & .List(i) & vbCrLf
            End If
        Next
        Clipboard.Clear
        Clipboard.SetText sTmp, vbCFText
    End With
End Sub

Private Sub mnuCopiar_Click()
    'Copiar los seleccionados
    CopiarList True
End Sub

Private Sub mnuCopiarTodos_Click()
    'copiar todos los elementos
    CopiarList False
End Sub

Private Sub mnuEditarRegistro_Click()
    CmdEditar_Click
End Sub

Módulos BAS:

BuscarCombo

...

gsDBR_bas (módulo para gsDBR.frm)

...

gsImprimir_Bas (módulo para el formulario Imprimir.frm)

...

MgsNotas (módulo para gsNotas)

...

Módulos de clases:

cgsFileOP (colección de rutinas y funciones para manejo de ficheros, etc.)

...

 


Volver a la página de gsNotas v3.0

la Luna del Guille o... el Guille que está en la Luna... tanto monta...