Const filename = "contacts.dat" Type Contact nombre As String cumpleano As String ciudad As String relacion As String email As String Declare Constructor () Declare Constructor (Byref aNombre As String, Byref aCumpleano As String, Byref aCiudad As String, Byref aRelacion As String, Byref aEmail As String) Declare Function obtenerRelacion() As String Declare Function toString() As String End Type Constructor Contact () nombre = "" cumpleano = "" ciudad = "" relacion = "" email = "" End Constructor Constructor Contact (Byref aNombre As String, Byref aCumpleano As String, Byref aCiudad As String, Byref aRelacion As String, Byref aEmail As String) nombre = aNombre cumpleano = aCumpleano ciudad = aCiudad relacion = aRelacion email = aEmail End Constructor Function Contact.obtenerRelacion() As String Return relacion End Function Function Contact.toString() As String Return nombre & ", " & cumpleano & ", " & ciudad & ", " & relacion & ", " & email End Function Dim Shared As Contact contactos() Dim Shared As Integer numContactos = 0 Function Parse(Byref entry As String) As Contact Dim As String parts(4) Dim As Integer position = 0, index = 0 While ((position = Instr(entry, ", ")) <> 0 And index < 4) parts(index) = Left(entry, position - 1) entry = Mid(entry, position + 2) index += 1 Wend parts(index) = entry Return Contact(parts(0), parts(1), parts(2), parts(3), parts(4)) End Function Sub escribeFichero(Byref newEntry As String) Dim As Integer file = Freefile If Open(filename For Append As #file) = 0 Then Print #file, newEntry Close #file Else Print "Unable to open database '" & filename & "' for writing" End If End Sub Sub leeFichero() Dim As Integer file = Freefile If Open(filename For Input As #file) <> 0 Then Print "The file '" & filename & "' does not exist. Do you want to create it? (y/n)" Dim As String response Input response If Lcase(response) = "y" Then If Open(filename For Output As #file) = 0 Then Print "File '" & filename & "' created successfully." Close #file Cls Else Print "Unable to create the file '" & filename & "'." End If Else Print "File not created." End If Else Dim As String entry While Eof(file) = 0 Line Input #file, entry numContactos += 1 Redim Preserve contactos(numContactos) contactos(numContactos - 1) = Parse(entry) Wend Close #file End If End Sub Sub anadirNuevaEntrada() Print "Type the new entry, without inverted commas, in the format:" Print "Name, Birth_Date, State, Relation, Email" Dim As String newEntry Line Input newEntry Dim As Contact contacto = Parse(newEntry) numContactos += 1 Redim Preserve contactos(numContactos) contactos(numContactos - 1) = contacto escribeFichero(newEntry) Print "The contact '" & newEntry & "' has been added to the database" End Sub Sub mostrarUltimaEntrada() If numContactos > 0 Then Print "The latest entry is: " & contactos(numContactos - 1).toString() Else Print "There are currently no entries in the database" End If End Sub Sub mostrarUltimaEntradaEspecial(Byref search As String) Dim As Integer index = numContactos - 1 While (index >= 0 And contactos(index).obtenerRelacion() <> search) index -= 1 Wend If index >= 0 Then Print "The latest " & search & " entry is " & contactos(index).toString() Else Print "There are currently no " & search & " entries" End If End Sub Sub showLatestFriendEntry() mostrarUltimaEntradaEspecial("Friend") End Sub Sub showLatestFamilyEntry() mostrarUltimaEntradaEspecial("Family") End Sub Sub ListarTodasEntradasXEdad() '? numContactos Dim As Integer i, j If numContactos > 0 Then Dim As Contact copiaContactos(numContactos - 1) For i = 0 To numContactos - 1 copiaContactos(i) = contactos(i) Next For i = 0 To numContactos - 2 For j = i + 1 To numContactos - 1 If copiaContactos(j).cumpleano > copiaContactos(i).cumpleano Then Swap copiaContactos(i), copiaContactos(j) End If Next Next For i = 0 To numContactos - 1 Print copiaContactos(i).toString() Next Else Print "There are currently no entries in the database" End If End Sub Sub Main() leeFichero() Dim As Integer opc = 0 While opc <> 6 Print !"\n Menu " Print " 1: Add a new entry" Print " 2: Show latest entry" Print " 3: Show latest Friend entry" Print " 4: Show latest Family entry" Print " 5: List all entries by age" Print !" 6: Close the program \n" Input "> ", opc Select Case opc Case 1 : anadirNuevaEntrada() Case 2 : mostrarUltimaEntrada() Case 3 : showLatestFriendEntry() Case 4 : showLatestFamilyEntry() Case 5 : ListarTodasEntradasXEdad() Case 6 : Print !"\nProgram closed" Case Else : Print !"\nPlease enter a number in the range 1..6" End Select Wend End Sub Main() Sleep