Un Gran Proyecto, Paso a Paso

 

Décima Entrega (27/Abr/97)
...Siempre hay cosas que se deben "ajustar" y "depurar"... de eso trata esta entrega, entre otras cosas.
Además en esta entrega se muestra cómo usar los menús PopUp, copiar los datos seleccionados de una lista en el portapapeles, usar un form genérico para seleccionar campos de una tabla y varios etcéteras...

Los links para conectar con las entregas anteriores y los archivos comprimidos están al final de la página.

En esta entrega de hoy, vamos a "depurar" algunas cosillas. Por ejemplo que si el foco no está en un TextBox no funcionan las opciones del Toolbar o de los menús; y también vamos a añadirle otras cosas nuevas, por ejemplo el poder compactar la base de datos, poder seleccionar la forma en que se va a clasificar, copiar y pegar los datos anteriormente grabados, etc.

Vamos pues a empezar por las cosillas que debemos modificar y añadir, para que toda esta funcionalidad "funcione".
Aquí te presento una lista de las cosas que se han añadido/modificado, para que "saltes" al sitio que más te interese, pero deberías de ver también el resto, porque en algunos casos están bastantes relacionados...

Modificación de los menús y nuevas opciones en el ToolBar.
Cambio en las declaraciones de las constantes y los listados para las nuevas opciones.
La rutina de Compactar la Base de Datos.
El form para seleccionar los datos para clasificar.
El form de mostrar la consulta con opociones para copiar en el clipboard la selección y usar PopUp Menús.
Ajustes en el form de consulta gsQBE.frm y el cálculo de los datos mostrados de MostCons.frm

Modificación de los menús y nuevas opciones en el ToolBar.

En primer lugar, desplazaremos a un nuevo menú todo lo relacionado con la "edición" de los registros. En el menú de Edición sólo vamos a dejar lo relacionado con los campos de texto y lo que se refiera a los registros, lo movemos de sitio; para ello se deberán efectuar una serie de cambios en las constantes usadas. Ahora voy a explicar los cambios, pero los valores de las constantes los vamos a cambiar después, ya que, como verás, se tendrán que cambiar de nuevo, porque se van a añadir nuevas opciones... y no es plan de repetir el código...
Bien, vamos al tajo, es decir curremos el tema...

Abre el formulario de gsNotas y pulsa en el editor de los menús,
Añade una nueva opción antes del menú de Ayuda que se llame Registros (o el nombre que prefieras), en este menú vamos a desplazar las opciones que ya están en el de Archivo y Edición.
Una vez que hagamos los cambios, el menú de Registro y el de Edición, quedarán de esta forma:

Menú de Edición Menú de Registros

Lo más complicado, al menos lo que necesita un poco de más trabajo a la hora de "ajustar" las llamadas, será el menú de Edición, porque al ser un "array", deberemos ajustar los índices... pero si "cargas" los listados, no tendrás mucho que hacer... otra cosa es que vayas modificando el proyecto anterior... estos son los problemas de "cambiar" de ideas cuando tienes las cosas hechas... si nunca te ha ocurrio, eres una persona afortunada... o que planifica bien las cosas... pero como yo no soy nada de eso... pues a joderse tocan... 8-)
Dejemos el "rollo" y vayamos al "grano". Los índices del menú de edición quedarán en el orden que aparece en la imagen de arriba y el último de los valores, será 9. Por otro lado, las opciones desplazadas del menú de edición, deberán tener ahora nombres propios, ya que al no estar en un "array" de menús, no podemos usar el índice, como se hacía en el caso anterior.
Los nombres que les he asignado, son estos: (acuerdate de quitarle el índice)

&Buscar... (mnuRegBuscar), Buscar Si&guiente (mnuRegBuscarSig) y Reempla&zar... (mnuRegReemplazar)

Además de cambiar los nombres de los menús, deberás asignar los "short-cuts", fijate también que he añadido "teclas rápidas" a las opciones de Guardar y Borrar, son las que normalmente uso para mis programas... tengo a la gente acostumbrada a que F9 es para guardar los datos y así me gusta hacerlo.
Antes de ver los cambios en el código, vamos a añadir dos nuevas opciones al menú de archivo y al toolbar, estas serán para clasificar y para compactar la base de datos. Esto también necesitará que se ajusten las constantes...
Fijate que el uso de constantes nos facilita la tarea... ya que sólo tendremos que cambiar el valor en las declaraciones, sin importarnos ni preocuparnos del resto del proyecto. Esto parece una "tontería", pero a la larga se agradece el haberlo hecho... imaginate la de cambios que tendríamos que hacer por estas "cuatro" chorradas que acabamos de cambiar, y si no lo crees, haz la prueba.

Veamos cómo queda el menú de Archivo una vez añadidas las nuevas opciones:

Menú de Archivo

Y ahora vamos a añadir a la barra de herramientas los nuevos botones. Las imagenes usadas para estas dos nuevas tareas son: clasif_.bmp y compact_.bmp. Los índices de los botones también han cambiado, ya que estas opciones las vamos a insertar entre Consulta y AcercaDe. Una vez añadidos estos botones, la apariencia será la siguiente:

el ToolBar

Una de las "ventajas" de los controles de Windows 95 que vienen con el VB5, es que a la hora de modificar el ImageList para añadir las nuevas imagenes, no te "advierte" que no puede estar "enlazado" con otro control... si aún no tienes la versión 5 de VB, sabrás a que me refiero... y la verdad que es "un coñazo" eso de tener que ir asignando de nuevo los índices de las imagenes del Toolbar, cuando añades o quitas. (Alguna ventaja debería tener tanta "incompatibilidad" que ha supuesto la nueva versión 5.0)

Cambio en las declaraciones de las constantes y los listados para las nuevas opciones.

Ahora si que podemos ver el código de las nuevas "definiciones" de las constantes, tanto para los menús de edición como para las nuevas opciones que se han añadido. En este listado verás también algunas nuevas declaraciones, las usaremos en las siguientes "añadiduras" que vamos a realizar.
Este código es para las declaraciones Generales del Form gsNotas.

 
'---------------------------------------------------------------
'Form para la entrada de datos de las Tareas        ( 7/Mar/97)
'
'Primera tentativa:      7/Mar/97
'Última actualización:  27/Abr/97
'
'(c)Guillermo Som, 1997
'---------------------------------------------------------------
Option Explicit
Option Compare Text

Dim sClasif$                        'orden de clasificación

' Referencia al objeto de arrastrar y soltar
Dim MiObjeto As DragDrop

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_Nuevo = 2
Const CMD_Actualizar = 3
Const CMD_Borrar = 4
Const CMD_Buscar = 6
Const CMD_BuscarSiguiente = 7
Const CMD_Consulta = 9
Const CMD_Clasificar = 11
Const CMD_Compactar = 13
Const CMD_Acerca = 15
Const CMD_Salir = 17
'
Const CMD_Reemplazar = 105
'
Const CMD_BuscarActual = 101
Const CMD_BuscarSigActual = 102
Const CMD_ReemplazarActual = 103
Const CMD_SeleccionarTodo = 104
'
'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
'Constantes para el menú de Edición
'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

El código del módulo global, también cambia, ya que necesitamos un nuevo elemento en nuestra variable definida, para poder asignar y recuperar el último valor "almacenado", para que de esta forma, al pulsar F4, se "pegue" el último valor que hemos guardado. Ahora veremos el código. También vamos a añadir una nueva función para quitar los caracteres de una cadena. Esto, entre otras cosas, lo vamos a usar para "filtrar" los caracteres de retorno de carro (CR) y cambio de línea (LF). Si te has dado cuenta, creo que sí, porque es evidente y se nota mucho, que en la descripción mostrada en el Data control, se mostraban como líneas verticales los cambios de línea, es decir cada código 10 y 13, se muestran como una línea vertical. Y la verdad es que queda feillo. Lo mismo ocurre en el ListBox de resultado de la consulta... (también le vamos a arreglar un par de "bugs").
Veamos primero el código que ha cambiado de la parte general del módulo glbNotas.bas:

 
'--------------------------------------------------------------
'glbNotas   Módulo para las declaraciones globales  (28/Feb/97)
'--------------------------------------------------------------
Option Explicit

Global NumCampos As Integer         'Numero de campos

Global elForm As Form

'Tipo para los fields (campos) de la base de datos.
Type Campo_t
    Nombre As String                'Name
    Tipo As Long                    'Type
    Tamaño As Integer               'Size
    Anterior As String              'Dato anterior
End Type
'...

Ahora le toca el turno a la nueva función de quitar caracteres:

 
Public Function QuitarCaracter(ByVal sValor As String, Optional ByVal vCaracter, _
				Optional ByVal sPoner) As String
    '----------------------------------------------
    ' Quitar los símbolos               ( 5/Jun/96)
    ' Si se especifica sPoner, se cambiará por ese carácter (26/Abr/97)
    '----------------------------------------------
    Dim i As Long
    Dim j As Long
    Dim sTmp As String
    Dim sCaracter$
    Dim sCh$, bPoner As Boolean
    
    If IsMissing(vCaracter) Then
        sCaracter = "., "
    Else
        sCaracter = vCaracter
    End If
    
    bPoner = False
    If Not IsMissing(sPoner) Then
        sCh = sPoner
        bPoner = True
    End If
    sTmp = ""
    For i = 1 To Len(sValor)
        If InStr(sCaracter, Mid$(sValor, i, 1)) = 0 Then
            sTmp = sTmp & Mid$(sValor, i, 1)
        ElseIf bPoner Then
            sTmp = sTmp & sCh
        End If
    Next
    QuitarCaracter = sTmp
End Function


'Esto deberás ponerlo en el Data1_Reposition, donde antes ponía Data1.Caption = sTmp

            Data1.Caption = QuitarCaracter(sTmp, vbCrLf, " ")

Arreglemos el menú de Edición, quitando las llamadas a la edición de registros y añade estas funciones para cuando pulses en los distintos menús. (Este código deberás pegarlo en el form gsNotas.frm)

 
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
    If ControlActual = 0 Then Exit Sub
    If Len(Trim$(Campos(ControlActual).Anterior)) Then
        Text1(ControlActual) = Campos(ControlActual).Anterior
    End If
End Sub

Private Sub mnuRegReemplazar_Click()
    cmdAccion_Click CMD_Reemplazar
End Sub

Private Sub mnuClasificar_Click()
    Accion CMD_Clasificar
End Sub

Private Sub mnuCompactar_Click()
    Accion CMD_Compactar
End Sub

Los cambios que deberemos efectuar en las acciones son los siguientes: (estos son los listados completos):
Fijate que ahora ha cambiado la forma de usar el LblStatus y el form deberá tener ahora dos etiquetas en la parte inferior, una para mostrar la posición dentro del TextBox y otra para informar de lo que estamos haciendo. También deberás cambiar las referencias que se hacen en los Text1_Click, etc. Aquí te muestro como quedaría este evento, los otros sólo tendrás que cambiar la forma de uso de este Label, así como el código que en el From_Resize... (sé que es un coñazo, pero ya te he advertido en varias ocasiones que esto lo voy cambiando conforme me da el punto...)
En el caso del KeyPress, he añadido nuevas opciones por si la fecha se escribe el formato ddmmaa o dd-mm-aa, convertirla en el formato estándard: dd/mm/aa (si no es este el que tienes configurado, deberás cambiarlo)

 
'Esto es lo que debes cambiar en el From_Resize:
    'move es más rápido que efectuar los 3 cambios
    LblStatus(0).Move 30, ScaleHeight - 225
    LblStatus(1).Top = LblStatus(0).Top
    
    'El alto del text de la descripción
    With Text1(cDescripcion)
        .Height = Label1(4).Top - .Top - 90
        LblStatus(1).Width = .Width
    End With
'...


'En el form_Load deberás añadir estas líneas antes de cargar la tabla:
'...
    sClasif = Trim$(LeerIni(ficIni, "General", "Clasif_" & sUsuario, "ID"))
    If Len(sClasif) = 0 Then
        sClasif = "ID"
    End If


Private Sub Text1_Click(Index As Integer)
    LblStatus(0) = "(" & Text1(Index).SelStart + 1 & "/" & Text1(Index).MaxLength & ")"
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 = dbDate Then
        Select Case KeyAscii
        Case Asc("-"), Asc("."), Asc("/")
            KeyAscii = Asc(sSepFecha)
        End Select
    End If
    If KeyAscii = 13 Then
        If Campos(Index).Tipo = dbDate Then
            If Len(Text1(Index).Text) = 6 Then
                sTmp = Text1(Index)
                sTmp = Left$(sTmp, 2) & "/" & Mid$(sTmp, 3, 2) & "/" & Right$(sTmp, 2)
                Text1(Index) = sTmp
            ElseIf Len(Text1(Index).Text) > 7 Then
                sTmp = Text1(Index)
                If Mid$(sTmp, 3, 1) = "-" Then
                    sTmp = Left$(sTmp, 2) & "/" & Mid$(sTmp, 4, 2) & "/" & Mid$(sTmp, 7, 2)
                    Text1(Index) = sTmp
                End If
            End If
            KeyAscii = 0
        End If
        If Index <> cDescripcion And Index <> cAsunto Then
            SendKeys "{TAB}"
        End If
    End If
End Sub


Private Sub Accion(Index As Integer)
    Static sBuscar As String
    Static lngUltimaPos As Long
    Static UltimoControl As Integer
    Dim lngPosActual As Long
    Dim sTmp As String
        
    LblStatus(1).Tag = LblStatus(1).Caption
    
    Select Case Index
    Case CMD_BuscarActual, CMD_BuscarSigActual, CMD_ReemplazarActual
        'Si no estamos en un Text de búsqueda, salir
        If ControlActual = 0 Then Exit Sub
    End Select
    
    'para procesar las otras acciones adicionales   (15/Abr/97)
    Select Case Index
    Case CMD_BuscarActual
        'Si hay texto seleccionado...
        With Text1(ControlActual)
            If .SelLength > 0 Then
                sBuscar = Trim$(.SelText)
            End If
        End With
        'Para "personalizar" la sección de búsqueda...
        gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
        If gsBuscar(sBuscar, , "Buscar en el campo actual") > cFFAc_IDLE Then
            sBuscar = Trim$(sBuscar)
            If Len(sBuscar) Then
                LblStatus(1) = "Buscando en el campo actual " & sBuscar & "..."
                DoEvents
                lngUltimaPos = 0&
                UltimoControl = ControlActual
                lngPosActual = InStr(Text1(ControlActual), sBuscar)
                If lngPosActual Then
                    lngUltimaPos = lngPosActual + 1
                    'posicionarse en esa palabra:
                    With Text1(ControlActual)
                        .SelStart = lngPosActual - 1
                        .SelLength = Len(sBuscar)
                    End With
                Else
                    Beep
                    MsgBox "No se ha hallado el texto buscado en el campo actual: " & Text1(ControlActual).DataField, vbOK + vbInformation, "Buscar en el campo actual"
                End If
                'posicionarse en ese control
                Text1(ControlActual).SetFocus
            End If
        End If
    Case CMD_BuscarSigActual
        'Si no hay nada hallado con anterioridad
        'o no se ha procesado la última búsqueda en este control
        If UltimoControl <> ControlActual Or Len(sBuscar) = 0 Or lngUltimaPos = 0& Then
            Accion CMD_BuscarActual
        Else
            LblStatus(1) = "Buscando " & sBuscar & "..."
            DoEvents
            lngPosActual = InStr(lngUltimaPos, Text1(ControlActual), sBuscar)
            If lngPosActual Then
                lngUltimaPos = lngPosActual + Len(sBuscar)
                'posicionarse en esa palabra:
                With Text1(ControlActual)
                    .SelStart = lngPosActual - 1
                    .SelLength = Len(sBuscar)
                End With
            Else
                lngUltimaPos = 1&
                Beep
                MsgBox "No se ha hallado el texto buscado en el campo actual: " & Text1(ControlActual).DataField, vbOK + vbInformation, "Buscar en el campo actual"
            End If
            'posicionarse en ese control
            Text1(ControlActual).SetFocus
        End If
    Case CMD_ReemplazarActual
        'Si hay texto seleccionado...
        With Text1(ControlActual)
            If .SelLength > 0 Then
                sBuscar = Trim$(.SelText)
            End If
        End With
        
        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, , "Reemplazar en el campo actual")
        If iFFAccion <> cFFAc_Cancelar Then
            MousePointer = vbHourglass
            DoEvents
            sBuscar = Trim$(sFFBuscar)
            If Len(sFFBuscar) <> 0 And Len(sFFPoner) <> 0 Then
                If iFFAccion = cFFAc_Reemplazar Or iFFAccion = cFFAc_ReemplazarTodo Then
                    LblStatus(1) = "Reemplazando " & sBuscar & "..."
                    DoEvents
                    lngUltimaPos = 0&
                    UltimoControl = ControlActual
                    lngPosActual = InStr(Text1(ControlActual), sBuscar)
                    If lngPosActual Then
                        lngUltimaPos = lngPosActual + Len(sBuscar)
                        sTmp = Text1(ControlActual).Text
                        sTmp = Left$(sTmp, lngPosActual - 1) & sFFPoner & Mid$(sTmp, lngPosActual + Len(sFFBuscar))
                        Text1(ControlActual).Text = sTmp
                        'Si sólo es reemplazar uno...
                        If iFFAccion = cFFAc_Reemplazar Then Exit Sub
                        'Cambiar todas las coincidencias en el mísmo text
                        lngUltimaPos = 1
                        Do
                            lngPosActual = InStr(lngUltimaPos, sTmp, sFFBuscar)
                            If lngPosActual Then
                                lngUltimaPos = lngPosActual + 1
                                sTmp = Left$(sTmp, lngPosActual - 1) & sFFPoner & Mid$(sTmp, lngPosActual + Len(sFFBuscar))
                                Text1(ControlActual).Text = sTmp
                            End If
                        Loop While lngPosActual
                        DoEvents
                    Else
                        Beep
                        MsgBox "No se ha hallado el texto buscado en el campo actual: " & Text1(ControlActual).DataField, vbOK + vbInformation, "Buscar en el campo actual"
                    End If
                    'Si se ha reemplazado to, no debe estar esta palabra...
                    lngUltimaPos = 0&
                End If
            End If
            MousePointer = vbDefault
            DoEvents
        End If
    Case CMD_SeleccionarTodo
        With Text1(ControlActual)
            .SelStart = 0
            .SelLength = Len(.Text)
        End With
    Case CMD_Salir
        cmdSalir_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
            .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
            Data1.RecordSource = "select * from " & sTabla & " order by " & sClasif
            Data1.Refresh
            If Err Then
                Err = 0
                Data1.RecordSource = "select * from " & sTabla & " order by ID"
                Data1.Refresh
            End If
            On Local Error GoTo 0
            GuardarIni ficIni, "General", "Clasif_" & sUsuario, sClasif
            YaEstoyAqui = False
        End If
    Case CMD_Compactar
        YaEstoyAqui = True
        CompactarBase
        YaEstoyAqui = False
    Case Else
        cmdAccion_Click Index
    End Select
    LblStatus(1) = LblStatus(1).Tag
End Sub


Private Sub cmdAccion_Click(Index As Integer)
    Static esNuevo As Boolean
    Dim i As Integer
    Static sBuscar As String
    Dim sTmp As String
    Dim BusquedaNoHallada As Boolean
    Dim j As Integer
    
    LblStatus(1).Tag = LblStatus(1).Caption
    
    Select Case Index
    Case CMD_Nuevo              'Nuevo registro
        If Not esNuevo Then
            YaEstoyAqui = True
            'Quitar la "posible" marca del Check
            Check1.Value = 0
            Data1.Recordset.AddNew
            esNuevo = True
            'Deshabilitar los botones, excepto el de guardar
            For i = CMD_Nuevo To CMD_Consulta
                Toolbar1.Buttons(i).Enabled = False
            Next
            Toolbar1.Buttons(CMD_Actualizar).Enabled = True
            Data1.Enabled = False
            'Asignar la fecha actual
            Text1(cFecha) = Format$(Now, "Short Date")
            Text1(cFechaInicio) = Text1(cFecha)
            Text1(cTerminada) = "0"
            YaEstoyAqui = False
            Text1(cFecha).SetFocus
        End If
    Case CMD_Actualizar
        'Volver a habilitar los botones y poner la variable a False
        For i = CMD_Nuevo To CMD_Consulta
            Toolbar1.Buttons(i).Enabled = True
        Next
        esNuevo = False
        'Guardar el contenido de cada uno de los campos
        With Data1
            If .EditMode = EM_ADDNEW Then
                .Recordset.Update
            Else
                .Recordset.Edit
                .Recordset.Update
                If .EditMode = 0 Then
                    '
                Else
                    .UpdateControls
                End If
            End If
            .Enabled = True
            'A ver si así se actualiza correctamente
            If Val(.Recordset.Terminada) Then
                Check1.Value = 1
            Else
                Check1.Value = 0
            End If
            'Actualizar el contenido Anterior al dato actual
            'para pegarlos con F4
            For i = cFecha To cTerminada
                Campos(i).Anterior = Text1(i)
            Next
            .Refresh
            .Recordset.MoveLast
        End With
        If ControlActual = 0 Then
            Text1(1).SetFocus
        End If
    Case CMD_Borrar             'Borrar registro
        If MsgBox("¿Seguro que quieres borrar este registro?", 4 + 32 + 256) = 6 Then
            With Data1
                .Recordset.Delete
                .Refresh
                If Not .Recordset.EOF Then
                    .Recordset.MoveLast
                Else
                    .Caption = "No hay registros"
                End If
            End With
        End If
    Case CMD_Buscar             'Buscar registros
        'Si no estamos en un Text de búsqueda, salir
        If ControlActual = 0 Then Exit Sub
        
        'Si hay texto seleccionado...
        With Text1(ControlActual)
            If .SelLength > 0 Then
                sBuscar = "*" & Trim$(.SelText)
            End If
        End With
        'Para "personalizar" la sección de búsqueda...
        gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
        If gsBuscar(sBuscar, , "Buscar datos") > cFFAc_IDLE Then
            sBuscar = Trim$(sBuscar)
            If Len(sBuscar) Then
                YaEstoyAqui = True
                LblStatus(1) = "Buscando " & sBuscar & "..."
                DoEvents
                Data1.Recordset.FindFirst Text1(ControlActual).DataField & " LIKE '" & sBuscar & "*'"
                If Data1.Recordset.NoMatch Then
                    Beep
                    MsgBox "No se ha hallado el dato buscado en el campo: " & Text1(ControlActual).DataField, vbOK + vbInformation, "Buscar"
                    Text1(ControlActual).SetFocus
                Else
                    sTmp = sBuscar
                    If Left(sTmp, 1) = "*" Then
                        sTmp = Mid$(sTmp, 2)
                    End If
                    '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
                YaEstoyAqui = False
            End If
        End If
    Case CMD_BuscarSiguiente
        If Len(sBuscar) = 0 Then
            cmdAccion_Click CMD_Buscar
        Else
            YaEstoyAqui = True
            LblStatus(1) = "Buscando " & sBuscar & "..."
            DoEvents
            Data1.Recordset.FindNext Text1(ControlActual).DataField & " LIKE '" & sBuscar & "*'"
            If Data1.Recordset.NoMatch Then
                Beep
                MsgBox "No se han hallado más coincidencias del dato buscado en el campo: " & Text1(ControlActual).DataField, vbOK + vbInformation, "Buscar Siguiente"
                Text1(ControlActual).SetFocus
            Else
                sTmp = sBuscar
                If Left(sTmp, 1) = "*" Then
                    sTmp = Mid$(sTmp, 2)
                End If
                '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
            YaEstoyAqui = False
        End If
    Case CMD_Reemplazar
        'Si no estamos en un Text de búsqueda, salir
        If ControlActual = 0 Then Exit Sub
        'Si hay texto seleccionado...
        With Text1(ControlActual)
            If .SelLength > 0 Then
                sBuscar = "*" & Trim$(.SelText)
            End If
        End With
        
        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)
            '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
                    YaEstoyAqui = True
                    Data1.Recordset.FindFirst Text1(ControlActual).DataField & " LIKE '" & sBuscar & "*'"
                    If Data1.Recordset.NoMatch Then
                        Beep
                        MsgBox "No se ha hallado el dato buscado en el campo: " & Text1(ControlActual).DataField, vbOK + vbInformation, "Reemplazar"
                        Text1(ControlActual).SetFocus
                        BusquedaNoHallada = True
                    End If
                    YaEstoyAqui = False
                    Do Until BusquedaNoHallada
                        sTmp = Text1(ControlActual).Text
                        '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))
                            Text1(ControlActual).Text = sTmp
                        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))
                                Text1(ControlActual).Text = sTmp
                            End If
                        Loop While i
                        DoEvents
                        YaEstoyAqui = True
                        Data1.Recordset.FindNext Text1(ControlActual).DataField & " LIKE '" & sBuscar & "*'"
                        If Data1.Recordset.NoMatch Then
                            BusquedaNoHallada = True
                        Else
                            BusquedaNoHallada = False
                        End If
                        YaEstoyAqui = False
                    Loop
                End If
            End If
            MousePointer = vbDefault
            DoEvents
        End If
    End Select
    
    LblStatus(1) = LblStatus(1).Tag
End Sub

La rutina de compactar la base de datos.

Este es el código que se encarga de esa tarea. Es simple y "efectivo" Como seguridad, crea una copia del estado de la base antes de compactarla, de esta forma, podemos "recuperar" la información en caso de que se produzca algún error.

 
Sub CompactarBase()
    Dim i As Integer
    Dim dBaseTmp As String
    Dim sTmp As String
    Dim p As Integer
    
    On Local Error GoTo ErrCompactar 'Resume Next
    
    Set Data1.Recordset = Nothing
    Data1.Enabled = False
    'deshabilitar los botones
    With Toolbar1
        For i = 1 To CMD_Acerca - 1
            .Buttons(i).Enabled = False
        Next
    End With
    
    'Buscar el disco de trabajo de la base de datos
    LblStatus(1) = "COMPACTANDO " & UCase$(sBase)
    DoEvents
    '
    sTmp = ""
    'Buscar \
    For i = Len(sBase) To 1 Step -1
        If Mid$(sBase, i, 1) = "\" Then
            sTmp = Left$(sBase, i)
            Exit For
        End If
    Next
    If Len(sTmp) = 0 Then
        sTmp = CurDir$
    End If
    If Right$(sTmp, 1) <> "\" Then
        sTmp = sTmp & "\"
    End If
    
    dBaseTmp = sTmp & "~dBase2.mdb"
    If Len(Dir$(dBaseTmp)) Then Kill dBaseTmp
    If Len(Dir$(sTmp & "~dBase1.mdb")) Then Kill sTmp & "~dBase1.mdb"

    CompactDatabase sBase, dBaseTmp, dbLangSpanish, dbVersion20
    Name sBase As sTmp & "~dBase1.mdb"
    Name dBaseTmp As sBase
    If Len(Dir$(sTmp & "*.ldb")) Then Kill sTmp & "*.ldb"

CompactarSalir:
    On Local Error GoTo 0
    
    'habilitar los botones
    With Toolbar1
        For i = 1 To CMD_Acerca - 1
            .Buttons(i).Enabled = True
        Next
    End With
    Data1.Enabled = True
    CargarTabla
    Exit Sub
    
ErrCompactar:
    MsgBox "Error al compactar la base." & vbCrLf & Error$
    Err = 0
    Resume CompactarSalir
End Sub

El form para seleccionar los datos para clasificar.

Ahora tenemos que añadir un nuevo formulario para el tema de las opciones de clasificación.
Añade un nuevo form y dale el nombre: frmCampos. El aspecto que tendrá será el siguiente:

el form de selección de campos para clasificar

El código completo de este form será este que viene a continuación, fijate que se usa la variable global NumCampos que habrá que asignarla en el procedimiento de CargarTabla, justo cuando se "cuentan" los campos de la tabla cargada:

 
'...añadir a CargarTabla en gsNotas.frm...
    'Número de campos, empezando por cero
    j = Rs.Fields.Count - 1
    NumCampos = j


'--------------------------------------------------------------
'Form para seleccionar los campos                   (26/Abr/97)
'--------------------------------------------------------------
Option Explicit
Option Compare Text


Private Sub cmdAdd_Click()
    'Añadir el campo seleccionado
    Dim sTmp$, sCampo$
    Dim i&, j&
    
    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 cmdCerrar_Click()
    Hide
End Sub

Private Sub Form_Load()
    'añadir los campos a la lista
    Dim i&
    
    'centrarla
    Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
    With List1
        For i = 0 To NumCampos
            .AddItem Campos(i).Nombre
        Next
    End With
    Text1 = Campos(0).Nombre
End Sub

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

El form de mostrar la consulta con opociones para copiar en el clipboard la selección y usar PopUp Menús.

Ya sólo queda algunos ajuestes en el Form de mostrar la consulta (MostCons.frm), en el procedimiento de cancelar del form de consulta (gsQBE.frm) y un pequeño cambio en el form de Buscar y Reemplazar (gsDBR.frm).

 
'...comentar estas dos líneas del final del Sub IniciarCombo() del form gsDBR.frm:
    'Combo1(0).Text = ""
    'Combo1(1).Text = ""


'Esto es del gsQBE.frm

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

En el form de mostrar la consulta, añade un menú oculto con estas opciones: (Editar es el que se debe ocultar)
Al añadir estas opciones, nos permite seleccionar los datos mostrados y poder copiarlos en el portapapeles, el List1, deberá tener la opción MultiSelect puesta a 2-Extended.

 
Menú			nombre			Tecla acceso
--------------------	----------------	------------
Editar			mnuEdit
...&Copiar Selección	mnuCopiar		Ctrl+Ins
...Copiar &Todos	mnuCopiarTodos		Ctrl+C
...-			mnuEditSep1
...&Editar Registro	mnuEditarRegistro
'Este código es para MostCons.frm:

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 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.SetText sTmp, vbCFText
    End With
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 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

Ajustes en el form de consulta gsQBE.frm y el cálculo de los datos mostrados de MostCons.frm

Estos cambios son para quitar los CR y LF de los datos mostrados, además "arreglan" un fallillo de la longitud a mostrar en el resulatdo de la consulta.
Este es el listado a añadir/cambiar en el procedimiento ProcesarConsulta (lo incluyo completo, para que no haya lios):

 
Private Sub ProcesarConsulta(sBuscar As String)
    Const cLongitudMaxima = 100
    
    Dim Db As Database
    Dim strCampos As String
    Dim SQLtmp As String
    Dim MySnap As Recordset
    Dim i As Integer
    Dim flag 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
    Dim iLongCampo As Integer
    
    ReDim LongCampos(MaxCampos)

    On Local Error Resume Next

    Screen.MousePointer = vbHourglass

    Load MostrarConsulta
    MostrarConsulta!Command1.Caption = ""
    MostrarConsulta!List1.Clear
    
    'Abrir la base...
    Set Db = OpenDatabase(sBase)

    'Ejecutar orden SQL con los datos solicitados
    SQLtmp = "select * from " & sTabla & " where " & sBuscar & " order by ID"
    Set MySnap = Db.OpenRecordset(SQLtmp, dbOpenSnapshot)
    MySnap.MoveFirst
    If Err Then
        Err = 0
        '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
    End If

    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
            strCampos = strCampos & Left$(Trim$(Campos(k - 1).Nombre) & Space$(LongCampos(k - 1)), LongCampos(k - 1)) & ", "
        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
                strCampos = strCampos & sTmp & ", "
            End If
        Next
        MostrarConsulta!List1.AddItem strCampos
        MostrarConsulta!List1.ItemData(MostrarConsulta!List1.NewIndex) = MySnap("ID")
        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
    End If
    Screen.MousePointer = vbDefault
    MostrarConsulta!Command1.Caption = "Salir"
    Unload Me
End Sub


'Otra cosa que fallaba era el número de datos mostrados, 
'esto hay que hacerlo en el Form_Activate de MostCons.frm

    'Mostrar el número de datos hallados
    Caption = "Resultado de la búsqueda: " & List1.ListCount - 2 & " datos"

Y esto es todo, has podido ver cómo usar los menús PopUp y cómo copiar en la memoria el contenido de un listbox, entre otras cosas, espero que haya valido la pena esperar casi un minuto a que se cargue completamnete esta página.

Sigo con la advertencia, el código sólo está modificado para la versión de 32 bits, los usuarios de 16 bits no deberían tener mayor problema en ir siguiendo las indicaciones y modificar los listados. Es que realmente es "jodido" eso de tener que mantener las distintas versiones, lo siento...

Hasta la próxima entrega. ¡Feliz programación!
Nos vemos.

ir al índice principal

Entregas anteriores: Primera, Segunda, Tercera, Cuarta, Quinta, Sexta, Septima, Octava, Novena
Pues esta vez no te lo digo... No hace falta que eches un vistazo a las entregas anteriores...

Bajate las páginas HTML y los gráficos de las 7 primeras entregas. (gsnotas_htm.zip 84.3 KB)
(si es el mismo archivo, no se incluye esta entrega)
Para bajar las entregas 8ª y posteriores (incluidos los gráficos). (gsnotas2_htm.zip 39.8 KB)
Bajate los listados y los bitmaps para las barras de herramientas. (gsnotas.zip 60.3 KB)
(Estos tamaños variarán según el número de entregas; para saber el tamaño actual, deberías ver la última entrega)