El código de gsNotas v3.0 en formato zip: gsNotasv3.zip 166 KB
- Formularios:
- El código del formulario de entrada, selección de la base de datos (frmEntrada)
- El código del formulario principal (gsNotas.frm)
- cfgApartados (configuración de los apartados a usar)
- fBookmarks (lista de marcadores personalizables)
- fExecute (realizar consultas directas con código SQL)
- fMiniEditor
- frmCampos (seleccionar el orden en que se mostrarán los datos)
- gsDBR (cuadro de diálogo para realizar búsquedas / reemplazos)
- gsQBE (formulario para realizar consultas)
- Imprimir (Formulario para seleccionar la impresora a usar)
- MostrarConsulta (formulario en el que se mostrará el resultado de la consulta realizada en gsQBE)
- 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.)
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 SubEl 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 FunctionEl 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 SubfBookmarks (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 SubfExecute (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'------------------------------------------------------------------------------ ' 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 SubfrmCampos (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 SubgsDBR (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 SubgsQBE (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 SubImprimir (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 SubMostrarConsulta (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 SubMó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