Codigo y Formulario Modificado por mi (gensar)

Public cnAgenda As Connection

Public FlagDatosPersonales As Boolean

Public rsDatosPersonales As Recordset




Private Sub CmdActionButton_Click(Index As Integer)

'1 Mover al Inicio
'2 Mover al Anterior
'3 Mover al Siguiente
'4 Mover al Final

Select Case Index

Case 0 'Mover al Inicio
Me.rsDatosPersonales.MoveFirst

Case 1 'Mover al anterior

If Me.rsDatosPersonales.BOF = True Then

Me.rsDatosPersonales.MoveFirst
Else
Me.rsDatosPersonales.MovePrevious
End If

Case 2 'Mover al Siguiente

If Me.rsDatosPersonales.EOF = True Then
Me.rsDatosPersonales.MoveLast
Else
Me.rsDatosPersonales.MoveNext
End If


Case 3 'Mover al Final
Me.rsDatosPersonales.MoveLast

End Select


End Sub

Private Sub CmdAgregar_Click()

If Me.TxtNombre.Text = "" Or Me.TxtApepat.Text = "" Or Me.TxtApemat.Text = "" Or Me.TxtDireccion.Text = "" Then
MsgBox "no deje espacios en blanco"
Else
FrmMain.rsDatosPersonales.AddNew
FrmMain.rsDatosPersonales!nompersona = Me.TxtNombre.Text
FrmMain.rsDatosPersonales!apepat = Me.TxtApepat.Text
FrmMain.rsDatosPersonales!apemat = Me.TxtApemat.Text
FrmMain.rsDatosPersonales!direccion = Me.TxtDireccion.Text
FrmMain.rsDatosPersonales.Requery
End If


End Sub

Private Sub CmdBuscar_Click()

Select Case Me.CmbBuscar.Text

Case "Nombre"
FrmMain.rsDatosPersonales.MoveFirst
FrmMain.Buscar_DatosPersonales Me.TxtBuscar, 1

Case "Apellido Paterno"
FrmMain.rsDatosPersonales.MoveFirst
FrmMain.Buscar_DatosPersonales Me.TxtBuscar, 2

Case "Dirección"
FrmMain.rsDatosPersonales.MoveFirst
FrmMain.Buscar_DatosPersonales Me.TxtBuscar, 4
End Select

End Sub

Private Sub CmdEliminar_Click()

If Me.rsDatosPersonales.RecordCount > 0 Then
Me.rsDatosPersonales.Delete
Me.rsDatosPersonales.Requery
Else
MsgBox "Seleccione algun dato a eliminar"
End If

End Sub

Private Sub CmdModificar_Click()


If Me.TxtNombre.Text = "" Or Me.TxtApepat.Text = "" Or Me.TxtApemat.Text = "" Or Me.TxtDireccion.Text = "" Then
MsgBox "no deje espacios en blanco"
Else
FrmMain.rsDatosPersonales!nompersona = Me.TxtNombre.Text
FrmMain.rsDatosPersonales!apepat = Me.TxtApepat.Text
FrmMain.rsDatosPersonales!apemat = Me.TxtApemat.Text
FrmMain.rsDatosPersonales!direccion = Me.TxtDireccion.Text
FrmMain.rsDatosPersonales.Requery
End If


End Sub

Private Sub DataGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)

On Error GoTo horroroso

Me.TxtNombre.Text = Me.rsDatosPersonales!nompersona
Me.TxtApepat.Text = Me.rsDatosPersonales!apepat
Me.TxtApemat.Text = Me.rsDatosPersonales!apemat
Me.TxtDireccion.Text = Me.rsDatosPersonales!direccion

horroroso:
If Err.Number = 3021 Then
Exit Sub
End If

End Sub

Private Sub Form_Load()

Set cnAgenda = New Connection

With cnAgenda
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\AgendaInfoUnsaNoche\BaseDatos\Agenda.mdb;Persist Security Info=False"
.Open
End With

Set rsDatosPersonales = New Recordset

With rsDatosPersonales
.Source = "Select * from Tb_DatosPersonales"
.ActiveConnection = cnAgenda
.CursorType = adOpenDynamic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Options:=adCmdText
End With


Screen.MousePointer = vbDefault


Set FrmMain.DataGrid1.DataSource = FrmMain.rsDatosPersonales

Me.CmbBuscar.AddItem "Nombre", 0
Me.CmbBuscar.AddItem "Apellido Paterno", 1
Me.CmbBuscar.AddItem "Dirección", 2

End Sub



Public Sub Buscar_DatosPersonales(Buscado As String, IndiceLista As Integer)

Dim Criterio As String

If Buscado <> "" Then
Select Case IndiceLista
Case 0
Criterio = "CodPersona Like '" & Buscado & "'"
BuscarPrimer_DatosPersonales Criterio
Case 1
Criterio = "NomPersona Like '*" & Buscado & "*'"
BuscarPrimer_DatosPersonales Criterio
Case 2
Criterio = "ApePat Like '*" & Buscado & "*'"
BuscarPrimer_DatosPersonales Criterio
Case 3
Criterio = "ApeMat Like '*" & Buscado & "*'"
BuscarPrimer_DatosPersonales Criterio
Case 4
Criterio = "Direccion Like '*" & Buscado & "*'"
BuscarPrimer_DatosPersonales Criterio
End Select
Else
MsgBox "Ingrese alguna palabra para buscar", vbOKOnly, "Error"
End If

End Sub


Private Sub BuscarPrimer_DatosPersonales(Criterio As String)

' Buscar desde el siguiente registro a la posición actual
FlagDatosPersonales = True
FrmMain.rsDatosPersonales.MoveNext
If Not FrmMain.rsDatosPersonales.EOF Then
FrmMain.rsDatosPersonales.Find Criterio
End If

If FrmMain.rsDatosPersonales.EOF Then
FrmMain.rsDatosPersonales.MoveFirst
' Buscar desde el principio
FrmMain.rsDatosPersonales.Find Criterio
If FrmMain.rsDatosPersonales.EOF Then
FrmMain.rsDatosPersonales.MoveLast
FlagDatosPersonales = False
MsgBox ("No encuentro ese nombre")
End If
End If
End Sub


Function borrar()
Me.TxtNombre
End Function

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 2 Then
PopupMenu Me.MnuFunciones
End If


End Sub

Private Sub MnuAgregar_Click()

If Me.TxtNombre.Text = "" Or Me.TxtApepat.Text = "" Or Me.TxtApemat.Text = "" Or Me.TxtDireccion.Text = "" Then
MsgBox "no deje espacios en blanco"
Else
FrmMain.rsDatosPersonales.AddNew
FrmMain.rsDatosPersonales!nompersona = Me.TxtNombre.Text
FrmMain.rsDatosPersonales!apepat = Me.TxtApepat.Text
FrmMain.rsDatosPersonales!apemat = Me.TxtApemat.Text
FrmMain.rsDatosPersonales!direccion = Me.TxtDireccion.Text
FrmMain.rsDatosPersonales.Requery
End If


End Sub

Private Sub MnuEliminar_Click()


If Me.rsDatosPersonales.RecordCount > 0 Then
Me.rsDatosPersonales.Delete
Me.rsDatosPersonales.Requery
Else
MsgBox "Seleccione algun dato a eliminar"
End If


End Sub

Codigo para conectar Base de Datos

Conexión a Bases de Datos

En el la Ventana Referencias Marcar los siguientes datos

Declaro la Conexión

Public cnJUVC As Connection

Creacion del Flag para la busqueda

Public FlagEncontrarComisionRegantes As Boolean

Creo el Objeto

Public rsComisionRegantes As Recordset

Realizo la Conexión

Private Sub Form_Load()

Set cnJUVC = New Connection

With cnJUVC
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\JUVC\BaseDatos\JUVC.mdb;Persist Security Info=False"
.Open
End With

Set rsComisionRegantes = New Recordset

With rsComisionRegantes
.Source = "Select * from Tb_ComisionRegantes order by DesComsReg"
.ActiveConnection = cnJUVC
.CursorType = adOpenDynamic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Options:=adCmdText
End With


Screen.MousePointer = vbDefault

End Sub

Realizo la Búsqueda para la Tabla

Public Sub Buscar_ComisionRegantes(Buscado As String, IndiceLista As Integer)

Dim Criterio As String

If Buscado <> "" Then
Select Case IndiceLista
Case 0
Criterio = "CodComsReg Like '" & Buscado & "'"
BuscarPrimer_ComisionRegantes Criterio
Case 1
Criterio = "DesComsReg Like '*" & Buscado & "*'"
BuscarPrimer_ComisionRegantes Criterio
End Select
Else
MsgBox "Ingrese alguna palabra para buscar", vbOKOnly, "Error"
End If

End Sub

Private Sub BuscarPrimer_ComisionRegantes(Criterio As String)

' Buscar desde el siguiente registro a la posición actual
FlagEncontrarComisionRegantes = True
MdiFrmMain.rsComisionRegantes.MoveNext
If Not FrmMain.rsComisionRegantes.EOF Then
FrmMain.rsComisionRegantes.Find Criterio
End If

If FrmMain.rsComisionRegantes.EOF Then
FrmMain.rsComisionRegantes.MoveFirst
' Buscar desde el principio
FrmMain.rsComisionRegantes.Find Criterio
If FrmMain.rsComisionRegantes.EOF Then
FrmMain.rsComisionRegantes.MoveLast
FlagEncontrarComisionRegantes = False
MsgBox ("No encuentro ese nombre")
End If
End If
End Sub

Primer Examen de Visual Basic

1. Crear una carpeta en la unidad D llamada “VisualBasicExamenNoche”

2. Crear un nuevo proyecto en Visual Basic

3. Se crearan dos formularios nuevos uno llamado FrmCargos y el otro FrmPagos

4. En el Formulario FrmCargos Agregar dos Textbox uno llamado TxtCargo y el otro TxtSueldos, además de dos listas una llamada LstCargos y la otra llamada LstSueldos, y dos botones uno llamado CmdAgregar y el otro CmdEliminar

5. En el formulario FrmPagos agregar un combo llamado CmbCargo y un TextBox llamado TxtSueldo, se agregaran tres botones uno llamado CmdActualizar, otro llamado CmdPagar y otro llamado CmdCargos

6. Formulario FrmCargos

a. Se deberá poder añadir diferentes cargos con sus respectivos sueldos, presionando el respectivo botón y aparecer en las listas

b. Se deberá poder eliminar en las listas previa selección un cargo y un sueldo en las listas, previa pulsación en el botón y desaparecer de la lista

7. Formulario FrmPagos

a. El Botón CmdCargos permitirá visualizar el formulario cargos

b. El Botón CmdActualizar permitirá actualizar los datos de cargos del formulario FrmCargos al combo CmbCargo de FrmPagos

c. Cuando Seleccione el cargo debe de aparecer el pago que se efectuará

d. Cuando presione el botón pagar se deberá descontar el 15% del sueldo y aparecer el monto a pagar en un msgbox

8. Grabar el Proyecto en la Unidad D

9. Zipear el archivo

10. Enviarlo en correo electronico al correo del instructor jcprado78@hotmail.com añadiendo en el cuerpo de la carta el turno donde ustedes llevan el curso y el nombre de ustedes.

Puntos Adicionales

• Si se efectúa un control de errores
• Si se añaden funcionalidades adicionales que mejoren las funciones al usuario

Formulario Ventas

Private Sub CmbProducto_Click()

Me.TxtPrecio.Text = FrmProducto.LstPrecio.List(Me.CmbProducto.ListIndex)

End Sub

Private Sub MnuActualizarDatos_Click()

'Actualizo el combo


Me.CmbProducto.Clear

For Mover = 0 To FrmProducto.LstProducto.ListCount - 1

Me.CmbProducto.AddItem FrmProducto.LstProducto.List(Mover), Mover

Next


'actualizo la lista




End Sub

Private Sub MnuProductos_Click()

FrmProducto.Show

End Sub

Private Sub MnuVendedores_Click()

FrmVendedor.Show

End Sub

Formulario Vendedor

Private Sub CmdAgregar_Click()
If Me.TxtVendedor.Text <> "" Then
If IsNumeric(Me.TxtVendedor.Text) = False Then
Me.LstVendedor.AddItem Me.TxtVendedor.Text, Me.LstVendedor.ListCount
Else
MsgBox "Escribir solo texto"
End If
End If

Me.TxtVendedor.Text = ""
Me.TxtVendedor.SetFocus

End Sub

Private Sub CmdEliminar_Click()
On Error GoTo RevisarError

Me.LstVendedor.RemoveItem Me.LstVendedor.ListIndex

RevisarError:
If Err.Number = 5 Then
MsgBox "Seleccione algo para eliminar"
Exit Sub
End If

End Sub

Private Sub TxtVendedor_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Me.TxtVendedor.Text <> "" Then
If IsNumeric(Me.TxtVendedor.Text) = False Then
Me.LstVendedor.AddItem Me.TxtVendedor.Text, Me.LstVendedor.ListCount
Else
MsgBox "Escribir solo texto"
End If
End If

Me.TxtVendedor.Text = ""
Me.TxtVendedor.SetFocus

End If
End Sub

Formulario Producto

Dim AvisoN As Boolean
Dim AvisoT As Boolean

Private Sub CmdAgregar_Click()

AvisoN = False
AvisoT = False

'Comprobar el ingreso correcto de datos
If Me.TxtProducto.Text <> "" Then
If IsNumeric(Me.TxtProducto.Text) = False Then
'Me.LstProducto.AddItem Me.TxtProducto.Text, Me.LstProducto.ListCount
AvisoT = True
Else
MsgBox "Faltan datos..."
End If
End If


'Comprobar que la cantidad sea ingreso numérico
If Not IsNumeric(Me.TxtPrecio.Text) Or Val(Me.TxtPrecio.Text) <= 0 Then
MsgBox "Cantidad no válida..."
Exit Sub
Else
'Me.LstPrecio.AddItem Me.TxtPrecio.Text, Me.LstPrecio.ListCount
AvisoN = True
End If

If AvisoN = True And AvisoT = True Then
Me.LstProducto.AddItem Me.TxtProducto.Text, Me.LstProducto.ListCount
Me.LstPrecio.AddItem Me.TxtPrecio.Text, Me.LstPrecio.ListCount
End If



Me.TxtProducto.Text = ""
Me.TxtPrecio.Text = ""
Me.TxtProducto.SetFocus 'para ubicar el cursor en txtproducto



End Sub

Private Sub CmdEliminar_Click()
Me.LstPrecio.RemoveItem Me.LstPrecio.ListIndex
Me.LstProducto.RemoveItem Me.LstProducto.ListIndex

End Sub

Private Sub LstPrecio_Click()
Me.LstProducto.ListIndex = Me.LstPrecio.ListIndex

End Sub

Private Sub LstProducto_Click()
Me.LstPrecio.ListIndex = Me.LstProducto.ListIndex

End Sub