Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: plotor en Octubre 31, 2022, 09:32:42 am
-
hola estoy haciendo una aplicacion para entrar datos leer datos modificar datos y eliminar datos, todo sale bien menos borrar registro
dejo el codigo del formulario donde borra el registro
Dim Ruta As String
Dim Numregs As Long
Dim Canal As Integer
Dim LenRegTask As Integer
' Dim file As Task
Private Sub Form_Load()
Dim tk As Task
LenRegTask = Len(tk)
Ruta = App.Path & "\database.txt"
Call AbriBaseDatos
If (Numregs > 0) Then
' mostrar el primero:
End If
End Sub
Private Sub Form_Terminate()
Close #Canal
End Sub
Private Sub mnuMenu1_Click(Index As Integer)
Unload Me
Form2.Show
End Sub
Private Sub mnuRegistro_Click(Index As Integer)
Dim tk As Task
Dim Ix As Long
frmRegistro.TxtName = ""
Select Case Index
Case 0 ' nuevo registro
Call leerindice
With frmRegistro ' crear el registro
.Titulo = "Nuevo"
.Accion = ACCION_NUEVO
.Show 1
' guardarlo al final...
If (.Aceptado = True) Then
tk.Id = .Id
tk.Name = .Nombre
tk.Date = .Fecha
Seek (Canal), (LOF(Canal) + 1)
Put #Canal, , tk
'Numregs = (Numregs + 1)
End If
End With
Close #1
Case 1 ' Leer Registro
Ix = GetIndiceReg
If (Ix >= 0) Then
Seek (Canal), ((Ix * LenRegTask) + 1)
Get #Canal, , tk
With frmRegistro ' exponer el registro
.Titulo = "Leído"
.Accion = ACCION_LEER
.Id = tk.Id
.Nombre = tk.Name
.Fecha = tk.Date
.Show 1
End With
End If
Case 2 ' Editar registro.
Ix = GetIndiceReg
If (Ix >= 0) Then
Seek (Canal), ((Ix * LenRegTask) + 1)
Get #Canal, , tk
With frmRegistro ' editar registro
.Titulo = "Editar"
.Accion = ACCION_EDITAR
.Id = tk.Id
.Nombre = tk.Name
.Fecha = tk.Date
.Show 1
' guardarlo en su posición...
If (.Aceptado = True) Then
tk.Id = .Id
tk.Name = .Nombre
tk.Date = .Fecha
Seek (Canal), ((Ix * LenRegTask) + 1)
Put #Canal, , tk
End If
End With
End If
Case 3 ' Borrar registro.
Ix = GetIndiceReg
If (Ix >= 0) Then
' confirmar que es el correcto:
MsgBox "A continuación se mostrarán los datos del registro." & vbCrLf & _
"Pulse 'Aceptar' si es el registro que desea borrar o 'Cancelar' si no lo es...", vbInformation
Seek (Canal), ((Ix * LenRegTask) + 1)
Get #Canal, , tk
With frmRegistro ' editar registro
.Titulo = "Confirmar"
.Accion = ACCION_LEER
.Id = tk.Id
.Nombre = tk.Name
.Fecha = tk.Date
.Show 1
' borrarlo final...
If (.Aceptado = True) Then
Call Borrar(Ix)
End If
End With
End If
End Select
End Sub
' Solicita el índice del registro...
Private Function GetIndiceReg() As Long
If (Numregs > 0) Then
With frmIndiceReg
.Cantidad = Numregs
.Show 1
If (.Aceptado = True) Then
GetIndiceReg = (.Indice - 1)
Else
GetIndiceReg = -1
End If
End With
Else
GetIndiceReg = -1
End If
End Function
' Borrar un registro exige bastante esfuerzo y hay diferentes métodos
' el más sencillo (pero que puede ser costoso en tiempo si el fichero es grande)
' pasa por copiar los registros activos a otro fichero, eliminar el previo y renombrar el actual.
Private Sub Borrar(ByVal Indice As Long)
Dim ff As Integer, k As Long
Dim tk As Task
Dim temp As String
temp = Replace(Ruta, ".txt", ".tmp")
ff = FreeFile
Open temp For Binary As #ff
Seek (Canal), 1
' copiar y pegar los registros previos al índice seleccionado
For k = 0 To Indice - 1
Get #Canal, , tk
Put #ff, , tk
Next
' saltamos el registro a borrar
' copiar y pegar los registros tras el índice seleccionado
For k = Indice + 1 To Numregs
Get #Canal, , tk
Put #ff, , tk
Next
Close ' cierra ambos ficheros
Kill Ruta ' elimina el actual
Name temp As Ruta ' renombra el creado como el actual
Call AbriBaseDatos ' y lo abre como actual
End Sub
Private Sub AbriBaseDatos()
Canal = FreeFile
On Error GoTo falloFile
Open Ruta For Binary As #Canal
Numregs = (FileLen(Ruta) \ LenRegTask)
Exit Sub
falloFile:
Call MsgBox("Ocurrió un eror inesperado: " & CStr(Err.Number) & vbCrLf & _
"Mensaje: " & Err.Description & vbCrLf & _
"Se cerrará la aplicación...", vbCritical, "Error inesperado durante la apertura dle fichero")
Err.Clear
Unload Me
End Sub
Private Sub leerindice()
Dim tk As Task
Dim Ix As Long
Close #Canal
Canal = FreeFile
'Dim tk As Task
LenRegTask = Len(tk)
Ruta = App.Path & "\database.txt"
Call AbriBaseDatos
Numregs = (FileLen(Ruta) \ LenRegTask)
Numregs = Numregs + 1
Get #Canal, Numregs, tk
frmRegistro.LabId.Caption = Numregs
End Sub
y en un modulo
Public Type Task
Id As Integer
Date As Date
Name As String * 30
End Type
Public Enum Acciones
ACCION_NUEVO = 0
ACCION_LEER = 1
ACCION_EDITAR = 2
ACCION_BORRAR = 3
End Enum
el problema esta en la rutina private sub borrar(ByVal Indice As Long) no se lo que esta mal
si alguien me puede ayudar gracias
-
Hola no lo testie porque me toma mucho tiempos buscar los controles, proba esto sino avisa
Private Sub Borrar(ByVal Indice As Long)
Dim ff As Integer, k As Long
Dim tk As Task
Dim temp As String
temp = Replace(Ruta, ".txt", ".tmp")
ff = FreeFile
Open temp For Binary As #ff
Seek (Canal), 1
' copiar y pegar los registros previos al índice seleccionado
For k = 0 To Indice - 1
Get #Canal, , tk
Put #ff, , tk
Next
' saltamos el registro a borrar
Get #Canal, , tk
' copiar y pegar los registros tras el índice seleccionado
For k = Indice + 1 To Numregs
Get #Canal, , tk
Put #ff, , tk
Next
Close ' cierra ambos ficheros
Kill Ruta ' elimina el actual
Name temp As Ruta ' renombra el creado como el actual
Call AbriBaseDatos ' y lo abre como actual
End Sub
-
Hola Leandroa
muchas gracias Leandroa ahora si que elimina he hecho un pequeño cambio for k= indice + 2 to numregs. aqui dejo el codigo
' Borrar un registro exige bastante esfuerzo y hay diferentes métodos
' el más sencillo (pero que puede ser costoso en tiempo si el fichero es grande)
' pasa por copiar los registros activos a otro fichero, eliminar el previo y renombrar el actual.
Private Sub Borrar(ByVal Indice As Long)
Dim ff As Integer, k As Long
Dim tk As Task
Dim temp As String
temp = Replace(Ruta, ".txt", ".tmp")
ff = FreeFile
Open temp For Binary As #ff
Seek (Canal), 1
' copiar y pegar los registros previos al índice seleccionado
For k = 0 To Indice - 1
Get #Canal, , tk
Put #ff, , tk
Next
' saltamos el registro a borrar
Get #Canal, , tk
' copiar y pegar los registros tras el índice seleccionado
For k = Indice + 2 To Numregs
Get #Canal, , tk
Put #ff, , tk
Next
Close ' cierra ambos ficheros
Kill Ruta ' elimina el actual
Name temp As Ruta ' renombra el creado como el actual
Call AbriBaseDatos ' y lo abre como actual
End Sub
tema resuelto, muchas gracias
-
hola me ha surgido un pequeño problema en el programa, a la hora de eliminar el registro lo hace bien pero el problema esta en el indice de los registros.
yo introduzco los datos es un ejemplo:
1 a 12/11/2022
2 b 12/11(2022
3 c 12/11/2022
4 d 12/11/2022
elimino el registro numero 2, la salida del archivo despues de eliminar es el siguiente:
1 a 12/11/2022
3 c 12/11/2022
4 d 12/11/2022
bien lo hace correcto, pero cuando digo hacer un nuevo registro el indice me sale 4 me tendria que salir 5
Dim Ruta As String
Dim Numregs As Long
Dim Canal As Integer
Dim LenRegTask As Integer
' Dim file As Task
Private Sub Form_Load()
Dim tk As Task
LenRegTask = Len(tk)
Ruta = App.Path & "\database.txt"
Call AbriBaseDatos
If (Numregs > 0) Then
' mostrar el primero:
End If
End Sub
Private Sub Form_Terminate()
Close #Canal
End Sub
Private Sub mnuMenu1_Click(Index As Integer)
Unload Me
Form2.Show
End Sub
Private Sub mnuRegistro_Click(Index As Integer)
Dim tk As Task
Dim Ix As Long
frmRegistro.TxtName = ""
Select Case Index
Case 0 ' nuevo registro
Call leerindice
With frmRegistro ' crear el registro
.Titulo = "Nuevo"
.Accion = ACCION_NUEVO
.Show 1
' guardarlo al final...
If (.Aceptado = True) Then
tk.Id = .Id
tk.Name = .Nombre
tk.Date = .Fecha
Seek (Canal), (LOF(Canal) + 1)
Put #Canal, , tk
'Numregs = (Numregs + 1)
End If
End With
Close #1
Case 1 ' Leer Registro
Ix = GetIndiceReg
If (Ix >= 0) Then
Seek (Canal), ((Ix * LenRegTask) + 1)
Get #Canal, , tk
With frmRegistro ' exponer el registro
.Titulo = "Leído"
.Accion = ACCION_LEER
.Id = tk.Id
.Nombre = tk.Name
.Fecha = tk.Date
.Show 1
End With
End If
Case 2 ' Editar registro.
Ix = GetIndiceReg
If (Ix >= 0) Then
Seek (Canal), ((Ix * LenRegTask) + 1)
Get #Canal, , tk
With frmRegistro ' editar registro
.Titulo = "Editar"
.Accion = ACCION_EDITAR
.Id = tk.Id
.Nombre = tk.Name
.Fecha = tk.Date
.Show 1
' guardarlo en su posición...
If (.Aceptado = True) Then
tk.Id = .Id
tk.Name = .Nombre
tk.Date = .Fecha
Seek (Canal), ((Ix * LenRegTask) + 1)
Put #Canal, , tk
End If
End With
End If
Case 3 ' Borrar registro.
Ix = GetIndiceReg
If (Ix >= 0) Then
' confirmar que es el correcto:
MsgBox "A continuación se mostrarán los datos del registro." & vbCrLf & _
"Pulse 'Aceptar' si es el registro que desea borrar o 'Cancelar' si no lo es...", vbInformation
Seek (Canal), ((Ix * LenRegTask) + 1)
Get #Canal, , tk
With frmRegistro ' editar registro
.Titulo = "Confirmar"
.Accion = ACCION_LEER
.Id = tk.Id
.Nombre = tk.Name
.Fecha = tk.Date
.Show 1
' borrarlo final...
If (.Aceptado = True) Then
Call Borrar(Ix)
End If
End With
End If
End Select
End Sub
' Solicita el índice del registro...
Private Function GetIndiceReg() As Long
Dim tk As Task
If (Numregs > 0) Then
With frmIndiceReg
.Cantidad = Numregs
.Show 1
If (.Aceptado = True) Then
GetIndiceReg = (.Indice - 1)
Else
GetIndiceReg = -1
End If
End With
Else
GetIndiceReg = -1
End If
End Function
' Borrar un registro exige bastante esfuerzo y hay diferentes métodos
' el más sencillo (pero que puede ser costoso en tiempo si el fichero es grande)
' pasa por copiar los registros activos a otro fichero, eliminar el previo y renombrar el actual.
Private Sub Borrar(ByVal Indice As Long)
Dim ff As Integer, k As Long
Dim tk As Task
Dim temp As String
temp = Replace(Ruta, ".txt", ".tmp")
ff = FreeFile
Open temp For Binary As #ff
Seek (Canal), 1
' copiar y pegar los registros previos al índice seleccionado
For k = 0 To Indice - 1
Get #Canal, , tk
Put #ff, , tk
Next
' saltamos el registro a borrar
Get #Canal, , tk
' copiar y pegar los registros tras el índice seleccionado
For k = Indice + 2 To Numregs
Numregs = Numregs + 1
Get #Canal, , tk
Put #ff, , tk
Next
Close ' cierra ambos ficheros
Kill Ruta ' elimina el actual
Name temp As Ruta ' renombra el creado como el actual
Call AbriBaseDatos ' y lo abre como actual
End Sub
Private Sub AbriBaseDatos()
Canal = FreeFile
On Error GoTo falloFile
Open Ruta For Binary As #Canal
Numregs = (FileLen(Ruta) \ LenRegTask)
Exit Sub
falloFile:
Call MsgBox("Ocurrió un eror inesperado: " & CStr(Err.Number) & vbCrLf & _
"Mensaje: " & Err.Description & vbCrLf & _
"Se cerrará la aplicación...", vbCritical, "Error inesperado durante la apertura dle fichero")
Err.Clear
Unload Me
End Sub
Private Sub leerindice()
Dim tk As Task
Dim Ix As Long
Close #Canal
Canal = FreeFile
'Dim tk As Task
LenRegTask = Len(tk)
' frmRegistro.LabId.Caption = Numregs + 1
Ruta = App.Path & "\database.txt"
Call AbriBaseDatos
Numregs = (FileLen(Ruta) \ LenRegTask)
Numregs = Numregs + 1
Get #Canal, Numregs, tk
frmRegistro.LabId.Caption = Numregs
End Sub
he hecho algunas pruebas y no funciona creo que el problema esta en la variable numregs, pero no logro que funcione. alguien me puede ayudar. Gracias
-
Hola si podes subir tu ejemplo seria mas facil, a como lo veo por arriba tendrías que tomar el id del ultimo registro y sumarle 1, no se si seria lo mas efectivo o bien ya el archivo debería trabajar con una cabecera donde se almacena el ultimo ID asi de esa forma no se volvería a repetir un id y siempre seria auto incremental
-
gracias leandroa por contestar
el indice es con la variable numregs de la rutina leerindice
Private Sub leerindice()
Dim tk As Task
Dim Ix As Long
Close #Canal
Canal = FreeFile
'Dim tk As Task
LenRegTask = Len(tk)
Ruta = App.Path & "\database.txt"
Call AbriBaseDatos
Numregs = (FileLen(Ruta) \ LenRegTask)
Numregs = Numregs + 1
Get #Canal, Numregs, tk
frmRegistro.LabId.Caption = Numregs
End Sub
no se como pasar la variable numregs con el tk.id
lo de subir un archivo al foro no se como hacerlo, gracias
-
hola te pedia un ejemplo completo que subieras el proyecto para poder trabajar sobre el, pero bueno sigo tirando a siegas, declara una variable en el general NewID as long
Private Sub leerindice()
Dim tk As Task
Dim Ix As Long
Close #Canal
Canal = FreeFile
'Dim tk As Task
LenRegTask = Len(tk)
Ruta = App.Path & "\database.txt"
Call AbriBaseDatos
Numregs = (FileLen(Ruta) \ LenRegTask)
Numregs = Numregs + 1
Get #Canal, Numregs, tk
NewID = tk.id +1
frmRegistro.LabId.Caption = Numregs
End Sub
entonces cuando crees un nuevo registro deberías poner en Tk.id = NewID
-
gracias por responder Leandroa
he probado lo que dices y me pasa exactamente igual despues de eliminar el registro y volver a introducir un dato nuevo me sale el id 4
no he subido el archivo por que no se como se hace
gracias
-
hola leandorA
no he podido subir el archivo por que no sabia como hacerlo
https://workupload.com/file/U34LG2yc9Y3
espero que lo que lo haya hecho todo bien lo de subir el archivo al foro si no lo intentare otra vez
gracias