Mini Desafio solo para Avanzados y Gurus!!!

[LeandroA]

Este es un ejemplo de una agenda de teléfono en el cual se puede crear, eliminar, guardar, ir al siguiente, al anterior y buscar registros
bien puedes cambiar la extencion dat a txt

Insertar 3 textbox con sus nombres:
txtnombre
txttelef
txtcoment
6 commandbutton con sus nombres:
cmdnew
Cmdnext
Cmdprevious
Cmdsearch
cmdGuardar
cmdDelete

El Código:

'todas la variables DEBEN declararse
Option Explicit

'declara un tipo definido por el usuario que corresponde a un
'registro en el archivo PHONE.DAT
Private Type Persona
Nombre As String * 40
Telef As String * 40
Coment As String * 100
End Type



'declara variables que deben ser visibles
'en todos los procedimientos del formulario
Private gpersona As Persona
Private gfilenum As Integer
Private grecordlen As Long
Private gcurrentrecord As Long
Private glastrecord As Long
Private lpersona As Persona
Private lfilenum As Integer
Private lrecordlen As Long
Private lcurrentrecord As Long
Private llastrecord As Long

Dim posicion As Integer
Dim i As Integer


Public Sub salvaRegistro()

'llena a gpersona con los datos desplegados
gpersona.Nombre = txtnombre.Text
gpersona.Telef = txttelef.Text
gpersona.Coment = txtcoment.Text

'guarda gpersona en el registro actual
Put #gfilenum, gcurrentrecord, gpersona

End Sub

Public Sub MuestraRegistro()

'llena a gpersona con los datos del registro actual
Get #gfilenum, gcurrentrecord, gpersona

'despliega a gpersona
txtnombre.Text = Trim(gpersona.Nombre)
txttelef.Text = Trim(gpersona.Telef)
txtcoment.Text = Trim(gpersona.Coment)

'despliega el número de registro actual
'en el título del formulario
Form1.Caption = "Registro Nº:" & Str(gcurrentrecord) & " de " & Str(glastrecord)

End Sub


Private Sub cmdDelete_Click()
'graba la posicion del registro a borrar
posicion = gcurrentrecord
'Antes de borrar pide una confirmación del usuario.
If MsgBox("Eliminar este Registro?", vbYesNo) = vbNo Then
'Da el enfoque al campo txtName
txtnombre.SetFocus
'Sale del procedimiento sin borrar
Exit Sub
End If

'Para borrar fisicamente el registro actual del PHONE.DAT
'Todos los registros de este, a excepcion del registro actual son copiados
'a un archivo temporal (PHONE.TMP) y luego este archivo es renombrado a PHONE.DAT
'Se asegura de que PHONE.TMP no exista
If Dir("PHONE.TMP") = "PHONE.TMP" Then
Kill "PHONE.TMP"
End If

lrecordlen = Len(lpersona)
'obtiene el siguiente numero de archivo disponible
lfilenum = FreeFile
'abre el archivo para acceso aleatorio, si al archivo no existe lo crea
Open "PHONE.TMP" For Random As lfilenum Len = lrecordlen


'envia al PHONE.DAT Y A PHONE.TMP al primer registro
gcurrentrecord = 1
lcurrentrecord = 1

'pasara todo los datos de PHONE.DAT A PHONE.TMP
For i = 1 To glastrecord - 1
Get #gfilenum, gcurrentrecord, gpersona
'Aqui saltara el registro eliminado
If lcurrentrecord = posicion Then
gcurrentrecord = gcurrentrecord + 1
End If

Get #gfilenum, gcurrentrecord, gpersona

'despliega a gpersona
lpersona.Nombre = Trim(gpersona.Nombre)
lpersona.Telef = Trim(gpersona.Telef)
lpersona.Coment = Trim(gpersona.Coment)
'guarda los registros
Put #lfilenum, lcurrentrecord, lpersona
'suma un registro
gcurrentrecord = gcurrentrecord + 1
lcurrentrecord = lcurrentrecord + 1
Next
'cierra PHONE.DAT
Close gfilenum
'Lo elimina
Kill "PHONE.DAT"
'Renombra a PHONE.TMP como PHONE.DAT
Close lfilenum
Name "PHONE.TMP" As "PHONE.DAT"
'vuelve a cargar PHONE.DAT
Inicio
'devuelve la posicion del registro eliminado
gcurrentrecord = posicion
MuestraRegistro
End Sub

Private Sub cmdGuardar_Click()
salvaRegistro
End Sub

Private Sub form_load()
Inicio
End Sub
Private Sub Inicio()
'calcula la longitud de un registro
grecordlen = Len(gpersona)

'obtiene el siguiente numero de archivo disponible
gfilenum = FreeFile

'abre el archivo para acceso aleatorio, si al archivo no existe lo crea
Open "PHONE.DAT" For Random As gfilenum Len = grecordlen

'actualiza gcurrentrecord
gcurrentrecord = 1

'encuentra cual es el ultimo numero de registro del archivo
glastrecord = LOF(gfilenum) / grecordlen

'si el archivo acaba de ser creado
'establece glastrecord a 1
If glastrecord = 0 Then
glastrecord = 1
End If

'despliega el registro actual
MuestraRegistro
End Sub

Private Sub cmdnew_click()

'guarda el registro actual
salvaRegistro

'añade un nuevo registro en blanco
glastrecord = glastrecord + 1
gpersona.Nombre = " "
gpersona.Telef = " "
gpersona.Coment = " "
Put #gfilenum, glastrecord, gpersona

'actualiza a gcurrentrecord
gcurrentrecord = glastrecord

'despliega el registro que acaba de crear
MuestraRegistro

txtnombre.SetFocus

End Sub

Private Sub cmdnext_click()

'si el registro actual es el ultimo registro, emite un sonido
'y despliega un mensaje de error, en caso contrario, guarda
'el registro actual y salta al siguiente registro
If gcurrentrecord = glastrecord Then
Beep
MsgBox "Fin del Archivo", vbExclamation
Else
salvaRegistro
gcurrentrecord = gcurrentrecord + 1
MuestraRegistro
End If

txtnombre.SetFocus

End Sub

Private Sub cmdprevious_click()

'si el registro actual es el primer registro, emite un sonido
'y despliega un mensaje de error, en caso contrario, guarda
'el registro actual y salta al anterior registro
If gcurrentrecord = 1 Then
Beep
MsgBox "Fin del Archivo", vbExclamation
Else
salvaRegistro
gcurrentrecord = gcurrentrecord - 1
MuestraRegistro
End If

txtnombre.SetFocus

End Sub

Private Sub cmdexit_click()

'guarda el registro acual
salvaRegistro

' cierra el archivo
Close #gfilenum

End

End Sub
Private Sub cmdsearch_click()

Dim busca As String
Dim found As Integer
Dim recnum As Long
Dim tmp As Persona

'obtiene del usuario el nombre a buscar
busca = InputBox("Nombre a Buscar:", "Busqueda")

'si el usuario no da el nombre
If busca = " " Then
txtnombre.SetFocus
Exit Sub
End If

'convierte el nombre del usuario a buscar a mayúsculas
busca = UCase(busca)

'inicializa el indicador found en false
found = False

'busca el nombre que introdujo el usuario
For recnum = 1 To glastrecord
Get #gfilenum, recnum, tmp
If busca = UCase(Trim(tmp.Nombre)) Then
found = True
Exit For
End If
Next

'si encuentra el nombre despliega el registro
If found = True Then
salvaRegistro
gcurrentrecord = recnum
MuestraRegistro
Else
MsgBox "Nombre: " & busca & " no existe"
End If

txtnombre.SetFocus

End Sub