' Nuevo registro:
Private Sub Command5_Click()     ' recuperar el dato.
    Open App.Path & "\Numero1.txt" For Input As #1
    Do While Not EOF(1)
        Input #1, orden
    Loop
    Close #1
 

Open thj For Input As #1
            Input #1, orden
            Txtnum.Text = orden
            Input #1, fecha
            Label4.Caption = fecha
            Input #1, hora
            Label5.Caption = hora
            Input #1, contado
            Input #1, credito
 
            Input #1, cedu1, nom1
 
            txtCedula1.Text = cedu1
            txtNombre1.Text = nom1
 
            While Not EOF(1)
                Input #1, cantidad, producto, preciox, subtot
                cant.Text = cantidad
                prod.Text = producto
                Precio.Text = preciox
                subtotal.Text = subtot
                List1.AddItem cantidad & vbTab & producto & vbTab & preciox & vbTab & subtot
            Wend
        Close #1
 

private type RegCompra
    NumTicket          as integer         
    FechaCompra     as date
    Contado             as string * ???   
    Credito              as string * ???
 
    Producto             As String * 12
    PrecioX               As String * 8    ' por qué un string?. _Sería adecuado un single
    Cantidad             as integer
    SubTotal             As Double        ' no requiere un dobule, basta con un single, no vas a realizar cantidades astronómicas que escapen a un single.
end type
 

Private Enum MetodosDePago
   PAGO_AL_CONTRADO = 0
   PAGO_CON_TCREDITO = 1
End Enum
 

Private Enum MetodosDePago
   PAGO_AL_CONTRADO = 0
   PAGO_CON_TCREDITO = 1
End Enum
 
Private Type RegCompra
    NumTicket           As Integer     ' 1
    FechaCompra         As Date      ' 3
    MetodoDePago        As Byte      ' 11
    Alineacion            as byte         ' 12 nada solo hace que el registro sea una cantidad par, para ser más efectivo en lecturas  
 
    Producto            As String * 12  ' 13
    PrecioUnidad        As Single       ' 25
    Cantidad            As Integer       ' 29
    SubTotal            As Single        ' 31
 
End Type                                ' total: 34 bytes por registro
 
 
Private Canal           As Integer     ' Número de canal de comunicación con el fichero.
Private NumRegistros    As Long
Private reg1            As RegCompra   ' para leer registros
Private reg2            As RegCompra   '  para escribir registro, así diferenciados, será más difícil equivocarnos
 
 
' Leer Factura
Private Sub Command7_Click()
    If LeerFacturacion("poner aqui tu ruta") = True Then
        ' Activar en la interfaz lo que proceda
    Else
        ' desactivar de la interfaz lo que proceda
    End If
    ' para activar o desactivar es preferible tener una función que reciba un buleano y en base a ello activa o desactiva cada cosa que proceda... ya que también se llamaría desde 'cerrar'
End Sub
 
Private Function LeerFacturacion(ByRef Ruta As String) As Boolean
    Dim k As Integer
 
    If (Abrir(Ruta) = True) Then
        Get #Canal, 1, NumRegistros
 
        For k = 1 To NumRegistros
            Get #Canal, , reg1
            Call List1.AddItem(SerializarRegistro(reg1))
        Next
        ' Ahora si se quiere puede leerse de nuevo el primer registro para transferirlo a los textbox...
        list1.listindex = 0 ' para ello delegamos en el código que pondremos al listbox...
    End If
End Function
 
Private Sub TrasferirRegToTextbox(ByRef R As RegCompra)
    With R
        txtNumTicket.Text = .NumTicket
        txtFechaComprar.Text = CStr(.fecha)
        optMetodoPago(.MetodoDePago).Value = True  ' 2 controles option con indices 0 y 1
        'cheMetodoPago.value = .MetodoDePago   ' también vale un checkbox, que cambie su 'caption' según su valor, alternando entre 'Pago al contado' o 'Pago con Tarjeta de crédito'.
        txtProducto.Text = .Producto
        txtPrecioUnidad.Text = CStr(.PrecioUnidad)
        txtCantidad.Text = CStr(.Cantidad)
        txtSubtotal.Text = CStr(.SubTotal)
    End With
End Sub
 
Private Sub PosicionarRegistro(ByVal Numregistro As Long)
    If (Abierto = True) Then
        Seek (Canal), (1 + ((Numregistro-1) * LenB(reg1)))
    End If
End Sub
 
Private Function SerializarRegistro(ByRef Registro As RegCompra, ByVal Separador As String) As String
    With Registro
        SerializarRegistro = CStr(.NumTicket) & Separador & CStr(.FechaCompra) & _
               Separador & GetMetodoPago(.MetodoDePago) & Separador & .Producto & _
               Separador & CStr(.Cantidad) & Separador & CStr(.PrecioUnidad) & Separador & CStr(.SubTotal)
    End With
End Function
 
Private Function GetMetodoPago(ByVal Metodo As MetodosDePago) As String
    If (Metodo = PAGO_AL_CONTRADO) Then
        GetMetodoPago = "Contado"
    Else
        GetMetodoPago = "T. Credito"
    End If
End Function
 
 
Private Function ExisteFichero(ByRef Ruta As String) As Boolean
    Dim j As Integer, file As String
 
    j = InStrRev(Ruta, "\")
    If (j > 0) Then
        file = LCase$(Right$(Ruta, Len(Ruta) - j))
        ExisteFichero = (LCase$(Dir(Ruta, vbNormal)) = file)
    End If
End Function
 
Private Function Abrir(ByRef Ruta As String) As Boolean
    If (Abierto = True) Then Call Cerrar
 
    If (ExisteFichero(Ruta) = True) Then
        Canal = FreeFile
        On Error GoTo FalloApertura
        Open Ruta For Binary As #Canal
 
FalloApertura:
        If (Err.Number > 0) Then
            Call MsgBox("Error al intentar abrir el fichero en la ruta:" & vbCrLf & Ruta & vbCrLf & Err.Description, vbInformation, "Error de apertura:")
            Err.Clear
        Else
            Abrir = True
        End If
 
        On Error GoTo 0 ' hay que desactivar el controlador de errores, si no, cualquier error posterior cae en este interceptador (si es el último activo)...
    End If
End Function
 
Public Property Get Abierto() As Boolean
    Abierto = (Canal > 0)
End Property
 
Private Function Cerrar()
    Close #Canal
    canal = 0
    NumRegistros = 0
 
    ' desactivar de la interfaz lo que proceda...
End Function
 
Private Sub List1_Click()
    If (Abierto = True) Then
        Call PosicionarRegistro(List1.ListIndex + 1)
        Get #Canal, , reg1
        Call TrasferirRegToTextbox(reg1, vbtab)
    End If
End Sub
 

si Abierto=true luego
   ...
fin si

Private Enum MetodosDePago
   PAGO_AL_CONTRADO = 0
   PAGO_CON_TCREDITO = 1
End Enum
 
Private Type RegCompra
    NumTicket                       As Integer      ' 1
    FechaCompra                     As Date         ' 3
    MetodoDePago                    As Byte         ' 11
    Alineacion                      As Byte         ' 12 nada solo hace que el registro sea una cantidad par, para ser más efectivo en lecturas
 
    Producto                        As String * 12  ' 13
    PrecioUnidad                    As Single       ' 25
    Cantidad                        As Integer      ' 29
    SubTotal                        As Single       ' 31
End Type                                            ' total: 34 bytes por registro
 
Private Const DIR_COMIENZO_REGS     As Long = 9     ' 1+4+4
 
Private NumRegistros                As Long
Private AutonIncRegs                As Long
'
Private Canal                       As Integer     ' Número de canal de comunicación con el fichero.
Private reg1                        As RegCompra   ' para leer registros
Private reg2                        As RegCompra   '  para escribir registro, así diferenciados, será más difícil equivocarnos
 
 
 
 
Private Sub ComNuevaFacturacion_Click()
    If (Len(TxtFile.Text) > 0) Then
        Call CrearNuevaFacturacion(TxtFile.Text)
    End If
End Sub
 
Private Sub ComAbrirFacturacion_Click()
    Form2.Show 1
 
    If (Len(Form2.File) > 0) Then
        If (LeerFacturacion(App.Path & "\" & Form2.File) = True) Then
            Call Activar(True)
        Else
            Call Activar(False)
        End If
    End If
End Sub
 
Private Sub ComBuscar_Click()
    '
End Sub
 
Private Sub ComEditarRegistro_Click()
    '
End Sub
 
Private Sub ComGuardarRegistro_Click()
    '
End Sub
 
Private Sub ComRetirarRegistro_Click()
    '
End Sub
 
Private Sub ComSalir_Click()
    '
End Sub
 
Private Sub List1_Click()
    If (Abierto = True) Then
        Call PosicionarRegistro(List1.ListIndex + 1)
        Get #Canal, , reg1
        Call TrasferirRegToTextbox(reg1, vbTab)
    End If
End Sub
 
 
' ------------ Fin interfaz ------------------
 
Private Function LeerFacturacion(ByRef Ruta As String) As Boolean
    Dim k As Integer
 
    If (Abrir(Ruta) = True) Then
        Get #Canal, 1, NumRegistros
 
        For k = 1 To NumRegistros
            Get #Canal, , reg1
            Call List1.AddItem(SerializarRegistro(reg1))
        Next
        ' Ahora si se quiere puede leerse de nuevo el primer registro para transferirlo a los textbox...
        List1.ListIndex = 0 ' para ello delegamos en el código que pondremos al listbox...
    End If
End Function
 
Private Sub TrasferirRegToTextbox(ByRef R As RegCompra)
    With R
        txtNumTicket.Text = .NumTicket
        txtFechaComprar.Text = CStr(.fecha)
        optMetodoPago(.MetodoDePago).Value = True  ' 2 controles option con indices 0 y 1
        'cheMetodoPago.value = .MetodoDePago   ' también vale un checkbox, que cambie su 'caption' según su valor, alternando entre 'Pago al contado' o 'Pago con Tarjeta de crédito'.
        txtProducto.Text = .Producto
        txtPrecioUnidad.Text = CStr(.PrecioUnidad)
        txtCantidad.Text = CStr(.Cantidad)
        txtSubtotal.Text = CStr(.SubTotal)
    End With
End Sub
 
Private Sub PosicionarRegistro(ByVal Numregistro As Long)
    If (Abierto = True) Then
        Seek (Canal), (DIR_COMIENZO_REGS + ((Numregistro - 1) * LenB(reg1)))
    End If
End Sub
 
Private Function SerializarRegistro(ByRef Registro As RegCompra, ByVal Separador As String) As String
    With Registro
        SerializarRegistro = CStr(.NumTicket) & Separador & CStr(.FechaCompra) & _
               Separador & GetMetodoPago(.MetodoDePago) & Separador & .Producto & _
               Separador & CStr(.Cantidad) & Separador & CStr(.PrecioUnidad) & Separador & CStr(.SubTotal)
    End With
End Function
 
Private Function GetMetodoPago(ByVal Metodo As MetodosDePago) As String
    If (Metodo = PAGO_AL_CONTRADO) Then
        GetMetodoPago = "Contado"
    Else
        GetMetodoPago = "T. Credito"
    End If
End Function
 
 
Private Function ExisteFichero(ByRef Ruta As String) As Boolean
    Dim j As Integer, File As String
 
    j = InStrRev(Ruta, "\")
    If (j > 0) Then
        File = LCase$(Right$(Ruta, Len(Ruta) - j))
        ExisteFichero = (LCase$(Dir(Ruta, vbNormal)) = File)
    End If
End Function
 
' Abre un fichero que YA EXISTE: Cuando se solicita leer la facturación de uno.
' Abre un fichero que NO EXISTE: Cuando se trata de crear una nueva facturación.
Private Function Abrir(ByRef Ruta As String, Optional ByVal NoDebeExistir As Boolean = False) As Boolean
    If (Abierto = True) Then Call Cerrar
 
    If (ExisteFichero(Ruta) = False) Then
        If (NoDebeExistir = False) Then Exit Function
    End If
 
    Canal = FreeFile
    On Error GoTo FalloApertura
    Open Ruta For Binary As #Canal
 
FalloApertura:
    If (Err.Number > 0) Then
        Call MsgBox("Error al intentar abrir el fichero en la ruta:" & vbCrLf & Ruta & vbCrLf & Err.Description, vbInformation, "Error de apertura:")
        Err.Clear
    Else
        Abrir = True
    End If
 
    On Error GoTo 0 ' hay que desactivar el controlador de errores, si no, cualquier error posterior cae en este interceptador (si es el último activo)...
End Function
 
Public Property Get Abierto() As Boolean
    Abierto = (Canal > 0)
End Property
 
Private Function Cerrar()
    Close #Canal
    Canal = 0
    NumRegistros = 0
 
    ' desactivar de la interfaz lo que proceda...
End Function
 
 
' -------------------------------------------------
' -------- NUEVO DESDe AQUI ---------------
'--------------------------------------------------
' Index refiere al enésimo registor en el fichero.
' Si es -1 refiere al último, lo adecuaod cuando se añade.
' Si es entre 1 y NumRegistros, señala que es un registro que se ha editado...
Private Sub GuardarRegistro(ByRef R As RegCompra, Optional ByVal Index As Long = -1)
    If (R.NumTicket = 0) Then
        AutonIncRegs = (AutonIncRegs + 1)
        R.NumTicket = AutonIncRegs
    End If
 
    '
    If (Index = -1) Then
        NumRegistros = (NumRegistros + 1)
        Index = NumRegistros
    End If
 
    Call PosicionarRegistro(Index)
    Put #Canal, , R                                 ' Guarda el registro
    Put #Canal, 1, NumRegistros                     ' Guarda la cantidad de registros
    Put #Canal, , AutonIncRegs                      ' Guarda el valor de autoincrmeento (es un valor único).
End Sub
 
Private Function CrearNuevaFacturacion(ByRef NombreFile As String) As Boolean
    Dim Ruta As String
 
    Ruta = App.Path & "\" & NombreFile
    If (Abrir(Ruta, True) = True) Then
        NumRegistros = 0: AutonIncRegs = 0
        Put #Canal, 1, NumRegistros                 ' Guarda la cantidad de registros
        Put #Canal, , AutonIncRegs                  ' Guarda el valor de autoincrmeento (es un valor único).
 
        CrearNuevaFacturacion = True
    Else
        MsgBox "Parece que el fichero que intenta abrir ya existe, elija otro nombre (o bien ocurrió un error)..."
    End If
End Function
 
' Numreg: Permite seguir buscando más artículos a partir del previo que se encontró...
Private Function BuscarArticulo(ByRef Producto As String, Optional ByRef NumReg As Long = 0) As Boolean
    Dim k As Long, ptr As Long, inc As Long, Articulo As String * 12
 
    If (NumReg < NumRegistros) Then
        NumReg = (NumReg + 1)
        If (NumReg > 1) Then
            Call PosicionarRegistro(NumReg)
            ptr = Seek(Canal) + 12
        Else
            ptr = (DIR_COMIENZO_REGS + 12)                  ' Dir de comienzo de registros + desplazamiento al campo soliicitado.
        End If
 
        Producto = LCase(Producto)
        inc = LenB(reg1)
        For k = NumReg To NumRegistros
            Get #Canal, ptr, Articulo
 
            If (LCase$(Articulo) = Producto) Then
                Get #Canal, ptr - 12, reg1
                BuscarArticulo = True
                Exit For
            End If
            ptr = (ptr + inc)
        Next
 
        NumReg = k
    End If
End Function
 
' En cada fichero cada compra tiene un numero de ticket único (no hay dos repetidos, como si puede pasar con el nombre del artículo).
Private Function BuscarTicket(ByVal Ticket As Long) As Boolean
    Dim k As Long, ptr As Long, inc As Long, nTicket As Long
 
    ptr = DIR_COMIENZO_REGS                     ' Dir de comienzo de registros + desplazamiento al campo soliicitado=0.
    inc = LenB(reg1)
    For k = 1 To NumRegistros
        Get #Canal, ptr, nTicket
 
        If (LCase$(nTicket) = Ticket) Then
            Get #Canal, ptr, reg1
            BuscarTicket= True
            Exit For
        End If
        ptr = (ptr + inc)
    Next
End Function