He sacado un tiempito rápido... quizás se haya escapado algún gazapo, pués no lo he probado... queda a tu esfuerzo corregirlos, si los hubiere.
Como desconozco la interfaz que tengas, yo he optado por un sencillo menú, con 4 opciones:
- Nuevo
- Leer
- Editar
- Borrar
Este formulario principal, no tiene nada más en la interfaz.
Hay dos ventanas adicionales, una para elegir el índice de registro y otra para mostrar/editar los valores de la estructura.
Para la fecha he elegido un control DateTimePicker... que actúa como un combobox, que al desplegar muestra un calendario...
Te pongo el código y luego adjunto un enlace de descarga...
En el módulo, yace solo la estructura y una enumeración de las acciones:
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
La ventana principal:
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 mnuRegistro_Click(Index As Integer)
Dim tk As Task
Dim Ix As Long
Select Case Index
Case 0 ' nuevo registro
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
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
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
La ventana de selección de índice:
Public Aceptado As Boolean
Public Property Get Indice() As Integer
Indice = HScrRegistros.Value
End Property
Public Property Let Indice(ByVal X As Integer)
HScrRegistros.Value = X
End Property
Public Property Get Cantidad() As Integer
Cantidad = HScrRegistros.Max
End Property
Public Property Let Cantidad(ByVal X As Integer)
HScrRegistros.Max = X
End Property
Private Sub Form_Load()
HScrRegistros.Min = 1
Aceptado = False
End Sub
Private Sub HScrRegistros_Change()
Me.Caption = "Indice de registro: " & CStr(HScrRegistros.Value)
End Sub
Private Sub ComCancelar_Click()
Me.Hide
End Sub
Private Sub ComAceptar_Click()
Aceptado = True
Me.Hide
End Sub
La ventana de edición de la estructura:
Public Aceptado As Boolean
Public Property Let Titulo(ByRef X As String)
Me.Caption = "Registro: " & X
End Property
Public Property Let Accion(ByVal X As Acciones)
Dim b As Boolean
b = Not (X = ACCION_LEER)
HScrId.Enabled = b
TxtName.Enabled = b
dtpFecha.Enabled = b
End Property
Public Property Get Id() As Integer
Id = Me.HScrId.Value
End Property
Public Property Let Id(ByVal X As Integer)
Me.HScrId.Value = X
End Property
Public Property Get Nombre() As String
Nombre = Me.TxtName.Text
End Property
Public Property Let Nombre(ByRef X As String)
Me.TxtName.Text = X
End Property
Public Property Get Fecha() As Date
Fecha = dtpFecha.Value
End Property
Public Property Let Fecha(ByRef X As Date)
dtpFecha.Value = X
End Property
Private Sub ComCancelar_Click()
Me.Hide
End Sub
Private Sub ComAceptar_Click()
Aceptado = True
Me.Hide
End Sub
Private Sub Form_Load()
HScrId.LargeChange = 100
TxtName.MaxLength = 30 ' para que coincida con el campo Task.Name , en realidad puede hacerse sobre la interfaz en diseño.
Aceptado = False
End Sub
Private Sub HScrId_Change()
LabId.Caption = "Id: " & CStr(HScrId.Value)
End Sub
Por supuesto se puede hacer más simple y espagueti, pero así como mínimo te resultará muy fácil de ampliar... y tampoco resulta complejo que dificulte entenderlo.
Ejecútalo paso a paso con a tecla F8... para ir mirando donde te pudiera costar entender algo. Con cualquier duda, pregunta.
Descarga del proyecto:https://workupload.com/file/bU8u4LZYAlguna imagen de como se ve...
Autor
En línea
