Autor Tema: eliminar registro con open for binary  (Leído 180 veces)

0 Usuarios y 1 Visitante están viendo este tema.

plotor

  • Bit
  • Mensajes: 7
  • Reputación: +0/-0
    • Ver Perfil
eliminar registro con open for binary
« 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

Código: [Seleccionar]

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


Código: [Seleccionar]

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

LeandroA

  • Administrador
  • Petabyte
  • *****
  • Mensajes: 1115
  • Reputación: +150/-8
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #1 en: Noviembre 11, 2022, 05:27:26 am »
Hola no lo testie porque me toma mucho tiempos buscar los controles, proba esto sino avisa

Código: [Seleccionar]
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

plotor

  • Bit
  • Mensajes: 7
  • Reputación: +0/-0
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #2 en: Noviembre 11, 2022, 08:28:26 am »
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

Código: [Seleccionar]

' 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

plotor

  • Bit
  • Mensajes: 7
  • Reputación: +0/-0
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #3 en: Noviembre 12, 2022, 09:24:40 am »
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





Código: [Seleccionar]

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





LeandroA

  • Administrador
  • Petabyte
  • *****
  • Mensajes: 1115
  • Reputación: +150/-8
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #4 en: Noviembre 12, 2022, 08:16:50 pm »
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

plotor

  • Bit
  • Mensajes: 7
  • Reputación: +0/-0
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #5 en: Noviembre 13, 2022, 08:58:17 am »
gracias leandroa por contestar
el indice  es con la variable numregs de la rutina leerindice


Código: [Seleccionar]
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




LeandroA

  • Administrador
  • Petabyte
  • *****
  • Mensajes: 1115
  • Reputación: +150/-8
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #6 en: Noviembre 13, 2022, 09:14:51 pm »
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

Código: [Seleccionar]
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 


plotor

  • Bit
  • Mensajes: 7
  • Reputación: +0/-0
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #7 en: Noviembre 14, 2022, 09:50:53 am »
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

plotor

  • Bit
  • Mensajes: 7
  • Reputación: +0/-0
    • Ver Perfil
Re:eliminar registro con open for binary
« Respuesta #8 en: Noviembre 24, 2022, 11:52:53 am »
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