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
