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.
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:
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:
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:
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 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
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.
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)