Cumplidos estos pasos de instalación, se visualizarán las pantallas siguientes:
EL CODIGO DEL SISTEMA MULTIIND
‘formulario Menu
Private Sub DBCOMERCIALIZ_Click()
COMERCIALIZACION.Show
End Sub
Private Sub DBMANUF_Click()
BASE_MANUFACTURAS.Show
End Sub
Private Sub DBPROY_Click()
BASE_PROYECTOS.Show
End Sub
Private Sub Form_Load()
MENU.Picture = LoadPicture("")
Aplicar_skin Me
ShockwaveFlash1.Movie = App.Path & "MultiIndMOVIE.swf"
ShockwaveFlash1.Play
End Sub
Private Sub FRMCOSTOS_Click()
COSTOS.Show
End Sub
Private Sub FRMDEMAN_Click()
Form1.Show
End Sub
Private Sub FRMFABRICACION_Click()
FABRICACION.Show
End Sub
Private Sub FRMIDEAS_Click()
F5.Show
End Sub
Private Sub FRMREPORTES_Click()
REPORTES.Show
End Sub
Private Sub MNUACERCA_Click()
ACERCA.Show
End Sub
Private Sub MNUCOSULTARREP_Click()
CONSULTAREP.Show
End Sub
Private Sub MNUSALIR_Click()
End
Close All
End Sub
‘formulario Ingreso_Manufacturas
Dim DB As Database
Dim RS As Recordset
Dim K As Integer
Private Sub CMDGUARDAR_Click()
If TXT1 = "" Then
MsgBox "Falta el Código", 16
TXT1.SetFocus
Exit Sub
End If
If TXT2 = "" Then
MsgBox "Falta el Nombre del Proyecto", 16
TXT2.SetFocus
Exit Sub
End If
If TXT15 = "" Then
MsgBox "Falta escribir las Instrucciones", 16
TXT15.SetFocus
Exit Sub
End If
RS.Seek "=", TXT1
If Not RS.NoMatch Then
MsgBox "Codigo repetido", 16
TXT1 = ""
TXT1.SetFocus
Exit Sub
End If
RS.AddNew
RS!CODIGO = TXT1
RS!PROYECTO = TXT2
RS!PASOS = TXT15
RS!IN1 = TXT3
RS!IN2 = TXT4
RS!IN3 = TXT5
RS!IN4 = TXT6
RS!IN5 = TXT7
RS!IN6 = TXT8
RS!IN7 = TXT9
RS!IN8 = TXT10
RS!IN9 = TXT11
RS!IN10 = TXT12
RS!IN11 = TXT13
RS!IN12 = TXT14
RS.Update
Call LIMPIAR
Data1.Refresh
Data1.Recordset.MoveLast
TXT1.Text = Val(Text1.Text) + 1
End Sub
Private Sub LIMPIAR()
TXT1 = "-"
TXT2 = "-"
TXT3 = "-"
TXT4 = "-"
TXT5 = "-"
TXT6 = "-"
TXT7 = "-"
TXT8 = "-"
TXT9 = "-"
TXT10 = "-"
TXT11 = "-"
TXT12 = "-"
TXT13 = "-"
TXT14 = "-"
TXT15 = "-"
TXT1.SetFocus
End Sub
Private Sub CMDSALIR_Click()
Data1.Refresh
RS.Close
DB.Close
BASE_MANUFACTURAS.Command3.Visible = True
Unload Me
End Sub
Private Sub Form_Load()
Set DB = OpenDatabase(App.Path & "IND.mdb")
Set RS = DB.OpenRecordset("PROYECTOS")
RS.Index = "i_PROYECTOS"
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "PROYECTOS"
Data1.Refresh
Data1.Recordset.MoveLast
TXT1.Text = Val(Text1.Text) + 1
TXT2 = "-"
TXT3 = "-"
TXT4 = "-"
TXT5 = "-"
TXT6 = "-"
TXT7 = "-"
TXT8 = "-"
TXT9 = "-"
TXT10 = "-"
TXT11 = "-"
TXT12 = "-"
TXT13 = "-"
TXT14 = "-"
TXT15 = "-"
End Sub
Private Sub TXT1_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
If KeyAscii = 13 Then
TXT2.SetFocus
TXT2.Text = ""
End If
End Sub
Private Sub TXT2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT2.Text = UCase(TXT2.Text)
TXT3.SetFocus
TXT3.Text = ""
End If
End Sub
Private Sub TXT3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT4.SetFocus
TXT4.Text = ""
End If
End Sub
Private Sub TXT4_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT5.Text = ""
TXT5.SetFocus
End If
End Sub
Private Sub TXT5_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT6.Text = ""
TXT6.SetFocus
End If
End Sub
Private Sub TXT6_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT7.Text = ""
TXT7.SetFocus
End If
End Sub
Private Sub TXT7_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT8.Text = ""
TXT8.SetFocus
End If
End Sub
Private Sub TXT8_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT9.Text = ""
TXT9.SetFocus
End If
End Sub
Private Sub TXT9_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT10.Text = ""
TXT10.SetFocus
End If
End Sub
Private Sub TXT10_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT11.Text = ""
TXT11.SetFocus
End If
End Sub
Private Sub TXT11_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT12.Text = ""
TXT12.SetFocus
End If
End Sub
Private Sub TXT12_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT13.Text = ""
TXT13.SetFocus
End If
End Sub
Private Sub TXT13_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT14.Text = ""
TXT14.SetFocus
End If
End Sub
Private Sub TXT14_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
TXT15.Text = ""
TXT15.SetFocus
End If
End Sub
Private Sub TXT15_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
CMDGUARDAR.SetFocus
End If
End Sub
‘Formulario Ingreso_clientes
Dim DBC As Database
Dim rc As Recordset
Private Sub CMD1_Click() 'GUARDAR
If T1.Text = "" Then
MsgBox "FALTA CODIGO", 16
T1.SetFocus
Exit Sub
End If
If T2.Text = "" Then
MsgBox "FALTA NOMBRE", 16
T2.SetFocus
Exit Sub
End If
If T3.Text = "" Then
MsgBox "FALTA DIRECCION", 16
T3.SetFocus
Exit Sub
End If
If T4.Text = "" Then
MsgBox "FALTA TELEFONO", 16
T4.SetFocus
Exit Sub
End If
rc.AddNew
rc!CODIGO = T1.Text
rc!NOMBRE = T2.Text
rc!DIRECCION = T3.Text
rc!TELEFONO = T4.Text
rc.Update
Call LIMPIAR
Data1.Refresh
Data1.Recordset.MoveLast
T1.Text = Val(Text1.Text) + 1
End Sub
Private Sub LIMPIAR()
T1.Text = ""
T2.Text = ""
T3.Text = ""
T4.Text = ""
T1.SetFocus
End Sub
Private Sub CMD3_Click() 'SALIR
Data1.Refresh
rc.Close
DBC.Close
Unload Me
End Sub
Private Sub Form_Load()
Set DBC = OpenDatabase(App.Path & "IND.mdb")
Set rc = DBC.OpenRecordset("CLIENTES")
rc.Index = "I_CLIENTES"
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "CLIENTES"
Data1.Refresh
Data1.Recordset.MoveLast
T1.Text = Val(Text1.Text) + 1
End Sub
Private Sub T1_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T2_KeyPress(KeyAscii As Integer)
Call VAL_T(KeyAscii)
If KeyAscii = 13 Then
T2.Text = UCase(T2.Text)
End If
End Sub
Private Sub T3_KeyPress(KeyAscii As Integer)
Call VAL_T(KeyAscii)
End Sub
Private Sub T4_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
‘formulario REPORTES
Dim DB As Database
Dim RE As Recordset
Private Sub CMD1GUARDAR_Click()
If TCODRE.Text = "" Then
MsgBox "FALTA EL CODIGO", 16
TCODRE.SetFocus
Exit Sub
End If
If T1.Text = "" Then
MsgBox "FALTA EL NUMERO DE CLIENTES VISITADOS", 16
T1.SetFocus
Exit Sub
End If
If T2.Text = "" Then
MsgBox "FALTA EL NUMERO DE LLAMADAS REALIZADAS", 16
T2.SetFocus
Exit Sub
End If
If T3.Text = "" Then
MsgBox "FALTA EL NUMERO DE VENTAS REALIZADAS", 16
T3.SetFocus
Exit Sub
End If
If T4.Text = "" Then
MsgBox "FALTA EL NUMERO DE COBRANZAS REALIZADAS", 16
T4.SetFocus
Exit Sub
End If
If T5.Text = "" Then
MsgBox "FALTA ESCRIBIR LAS OBSERVACIONES DEL DIA", 16
T5.SetFocus
Exit Sub
End If
RE.Seek "=", TCODRE.Text
If Not RE.NoMatch Then
MsgBox "Codigo Repetido, revise los códigos de reportes anteriores y escoja uno diferente", 16
CMDCODRE.SetFocus
Exit Sub
End If
If TX1.Text = "" Then
MsgBox "FALTA EL NUMERO DE PRODUCTOS FABRICADOS", 16
TX1.SetFocus
Exit Sub
End If
If TX2.Text = "" Then
MsgBox "FALTA ESCRIBIR OBSERVACIONES SOBRE EL DIA", 16
TX2.SetFocus
Exit Sub
End If
RE.AddNew
RE!CODIGO = Val(TCODRE.Text)
RE!FECHA = TFCH.Text
RE!PLANIFICO = CHK4.Value
RE!PREPARO_VISITAS = CHK1.Value
RE!ADQUIRIO_MATERIALES = CHK3.Value
RE!VISITAS = Val(T1.Text)
RE!LLAMADAS = Val(T2.Text)
RE!PEDIDOS = Val(T3.Text)
RE!COBRANZAS = Val(T4.Text)
RE!PRODUCTOS = Val(TX1.Text)
RE!OBSERVACOMERCIO = (T5.Text)
RE!OBSERVAPRODUCCION = (TX2.Text)
RE.Update
Call LIMPIAR
Data1.Refresh
Data1.Recordset.MoveLast
TCODRE.Text = Text1.Text + 1
End Sub
Private Sub CMDCODRE_Click()
CONSULTARE.Show
End Sub
Private Sub Form_Load()
FRM1.Visible = True
FRM2.Visible = True
Data1.Refresh
TFCH = Date
Set DB = OpenDatabase(App.Path & "IND.mdb")
Set RE = DB.OpenRecordset("REPORTES")
RE.Index = "I_REPORTES"
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "REPORTES"
Data1.Refresh
Label2.Visible = True
TCODRE.Visible = True
Data1.Recordset.MoveLast
TCODRE.Text = Val(Text1.Text) + 1
T5 = "-"
TX2 = "-"
End Sub
Private Sub LIMPIAR()
T1.Text = ""
T2.Text = ""
T3.Text = ""
T4.Text = ""
T5.Text = ""
TX1.Text = ""
TX2.Text = ""
CHK1.Value = 0
CHK2.Value = 0
CHK3.Value = 0
CHK4.Value = 0
End Sub
Private Sub Option1_Click()
FRM1.Visible = True
FRM2.Visible = False
Label2.Visible = True
TCODRE.Visible = True
Label2.Left = 300
TCODRE.Left = 1700
End Sub
Private Sub Option2_Click()
FRM1.Visible = False
FRM2.Visible = True
Label2.Visible = True
TCODRE.Visible = True
End Sub
Private Sub CMDSALIR_Click()
Data1.Refresh
RE.Close
DB.Close
Unload Me
End Sub
Private Sub T1_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T2_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T3_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T4_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub TX1_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
‘formulario Form1 para estadisticas
Private Sub Command1_Click()
DATOS.Show
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub TIPOS_Click()
If TIPOS.ListIndex = 0 Then
MSChart1.ChartType = VtChChartType2dBar
Exit Sub
End If
If TIPOS.ListIndex = 1 Then
MSChart1.ChartType = VtChChartType3dArea
Exit Sub
End If
If TIPOS.ListIndex = 2 Then
MSChart1.ChartType = VtChChartType2dBar
Exit Sub
End If
If TIPOS.ListIndex = 3 Then
MSChart1.ChartType = VtChChartType3dBar
Exit Sub
End If
If TIPOS.ListIndex = 4 Then
MSChart1.ChartType = VtChChartType2dPie
Exit Sub
End If
If TIPOS.ListIndex = 5 Then
MSChart1.ChartType = VtChChartType2dLine
Exit Sub
End If
End Sub
‘Formulario FABRICACION
Dim C(16), V(12), G(6), K(8), l(3), F(9) As String
Dim DB As Database
Dim RS As Recordset
Private Sub Command1_Click()
T1.Text = ""
T1.SetFocus
BASE_MANUFACTURAS.Show
BASE_MANUFACTURAS.Command3.Visible = False
End Sub
Private Sub Command2_Click()
If T1.Text = "" Then
MsgBox "ESCRIBA EL CODIGO DEL PROYECTO SELECCIONADO", vbCritical
T1.SetFocus
Exit Sub
End If
RS.Seek "=", T1.Text
If RS.NoMatch Then
MsgBox "NO EXISTE EL CODIGO", vbCritical
T1.SetFocus
Exit Sub
End If
Text1.Text = ""
Text1.Text = Text1.Text & RS!PROYECTO & vbCrLf
Text1.Text = Text1.Text & " INGREDIENTES " & vbCrLf
Text1.Text = Text1.Text & RS!IN1 & vbCrLf
Text1.Text = Text1.Text & RS!IN2 & vbCrLf
Text1.Text = Text1.Text & RS!IN3 & vbCrLf
Text1.Text = Text1.Text & RS!IN4 & vbCrLf
Text1.Text = Text1.Text & RS!IN5 & vbCrLf
Text1.Text = Text1.Text & RS!IN6 & vbCrLf
Text1.Text = Text1.Text & RS!IN7 & vbCrLf
Text1.Text = Text1.Text & RS!IN8 & vbCrLf
Text1.Text = Text1.Text & RS!IN9 & vbCrLf
Text1.Text = Text1.Text & RS!IN10 & vbCrLf
Text1.Text = Text1.Text & RS!IN11 & vbCrLf
Text1.Text = Text1.Text & RS!IN12 & vbCrLf
Text1.Text = Text1.Text & vbCrLf
Text1.Text = Text1.Text & " INSTRUCCIONES " & vbCrLf
Text1.Text = Text1.Text & RS!PASOS & vbCrLf
End Sub
Private Sub Form_Load()
Aplicar2_skin Me
Set DB = OpenDatabase(App.Path & "IND.mdb")
Set RS = DB.OpenRecordset("PROYECTOS")
RS.Index = "I_PROYECTOS"
End Sub
Private Sub OPabrir_Click()
Call abrir
End Sub
Private Sub OPfuente_Click()
Call fuente
End Sub
Private Sub OPguardarcomo_Click()
Call guardarcomo
End Sub
Private Sub OPnuevo_Click()
FABRICACION.Caption = " ( Sin Título ) "
Text1.Text = ""
T1.Text = ""
End Sub
Private Sub OPsalir_Click()
RS.Close
DB.Close
Unload Me
End Sub
Private Sub Command3_Click()
RS.Close
DB.Close
Unload Me
End Sub
Public Sub abrir()
On Error GoTo manipularerrorabrir
'muestra la caja de dialogo abrir archivo
With CommonDialog
.Filter = "ARCHIVOS DE TEXTO*.TXTTodos los Archivos*.*"
.DefaultExt = ".txt"
.ShowOpen
Open .FileName For Input As #1
FABRICACION.Caption = .FileName
End With
'limpia la caja de texto
Text1.Text = ""
'abre el archivo con las caracteristicas de texto previas
Text1.Text = Input$(LOF(1), #1)
Close #1
Exit Sub
''mensaje de error si no puede abrir el archivo
manipularerrorabrir:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al abrir el archivo"
End If
End Sub
Public Sub guardarcomo()
On Error GoTo manipularerrorguardar
With CommonDialog
.CancelError = True
.DefaultExt = ".txt"
.Filter = "TEXTO*.TXTTodos los Archivos*.*"
'muestra mensaje si desea sobreescribir en el archivo
.Flags = cdlOFNOverwritePrompt
.ShowSave
Open .FileName For Output As #1
FABRICACION.Caption = .FileName
End With
'escribir en el archivo los datos necesaros
Print #1, Text1.Text
'cierra el archivo ya guardado
Close #1
Exit Sub
'en caso de no poder abrir el archivo presenta mensaje de error
manipularerrorguardar:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al guardar el archivo"
End If
End Sub
Public Sub fuente()
'procedimiento que modifica el estilo del texto
On Error GoTo manipularerrorfuente
With CommonDialog
.CancelError = True
.FontName = Text1.FontName
.FontSize = Text1.FontSize
.FontBold = Text1.FontBold
.FontItalic = Text1.FontItalic
.FontUnderline = Text1.FontUnderline
.FontStrikethru = Text1.FontStrikethru
.Color = Text1.ForeColor
.Flags = cdlCFBoth Or cdlCFEffects
'muestra el cuadro de dialogo fuente
.ShowFont
End With
With CommonDialog
'aplica al cuadro de texto el estilo escogido
Text1.FontName = .FontName
Text1.FontSize = .FontSize
Text1.FontBold = .FontBold
Text1.FontItalic = .FontItalic
Text1.FontUnderline = .FontUnderline
Text1.FontStrikethru = .FontStrikethru
Text1.ForeColor = .Color
End With
Exit Sub
'en caso de error al abrir la caja de dialogo de fuente
manipularerrorfuente:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al abrir la caja de dialogo de estilos"
End If
End Sub
Private Sub T1_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub Text1_Change()
modificado = True
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
OPfuente.Enabled = (Text1.SelLength > 0)
End Sub
‘formulario F5 IDEAS
Dim C(16), V(12), G(6), K(8), l(3), F(9) As String
Dim u, J, a, b, W, s, T As Long
Dim P1, P2, P3, P4, P5, P6, P7 As String
Dim DB As Database
Dim RS, RV, RAJ, RMAT As Recordset
Private Sub Command1_Click() 'LIBRETA DE NOTAS
F1.Show
End Sub
Private Sub Form_Load()
Aplicar1_skin Me
Set DB = OpenDatabase(App.Path & "IND.mdb")
Set RS = DB.OpenRecordset("S")
RS.Index = "I_S"
Set RV = DB.OpenRecordset("V")
RV.Index = "I_V"
Set RAJ = DB.OpenRecordset("AJ")
RAJ.Index = "I_AJ"
Set RMAT = DB.OpenRecordset("MAT")
RMAT.Index = "I_MAT"
Text2.Text = "LA PALABRA DE DIOS ES VIVA Y EFICAZ"
End Sub
Private Sub GENERAR_Click()
Dim F As Integer
Randomize
F = Int(Rnd() * 18 + 1)
Select Case F
Case 1
Call GEN1
Case 2
Call GEN2
Case 3
Call GEN3
Case 4
Call GEN4
Case 5
Call GEN5 'hasta aqui 420,000
Case 6
Call GEN6 '2,000
Case 7
Call GEN7 '3,000
Case 8
Call GEN8 '212,000
Case 9
Call GEN9 '213,000 hasta aqui 850,000
Case 10
Call GEN10 '1,320,000 van 2,170,000
Case 11
Call GEN11 '2300 +
Case 12
Call GEN12 '1,283,000 van 3,455,000
Case 13
Call GEN13 '196,000
Case 14
Call GEN14 '21,000 van 3,672,000
Case 15
Call GEN15 '5,200
Case 16
Call GEN16 '300
Case 17
Call GEN17 '60,000
Case 18
Call GEN18 '237,000 van 4,000,000
End Select
End Sub
Private Sub MENUIMPRIMIR_Click()
Call imprimir
End Sub
Private Sub OPabrir_Click()
Call abrir
End Sub
Private Sub OPfuente_Click()
Call fuente
End Sub
Private Sub OPguardarcomo_Click()
Call guardarcomo
End Sub
Private Sub OPnuevo_Click()
F5.Caption = " ( Sin Título ) "
Text1.Text = ""
End Sub
Private Sub OPsalir_Click()
RS.Close
RV.Close
RAJ.Close
DB.Close
Unload Me
End Sub
'sub para abrir un archivo de texto
Public Sub abrir()
On Error GoTo manipularerrorabrir
'muestra la caja de dialogo abrir archivo
With CommonDialog
.Filter = "ARCHIVOS DE TEXTO*.TXTTodos los Archivos*.*"
.DefaultExt = ".txt"
.ShowOpen
Open .FileName For Input As #1
F5.Caption = .FileName
End With
'limpia la caja de texto
Text1.Text = ""
'abre el archivo con las caracteristicas de texto previas
Text1.Text = Input$(LOF(1), #1)
Close #1
Exit Sub
''mensaje de error si no puede abrir el archivo
manipularerrorabrir:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al abrir el archivo"
End If
End Sub
Public Sub guardarcomo()
On Error GoTo manipularerrorguardar
With CommonDialog
.CancelError = True
.DefaultExt = ".txt"
.Filter = "TEXTO*.TXTTodos los Archivos*.*"
'muestra mensaje si desea sobreescribir en el archivo
.Flags = cdlOFNOverwritePrompt
.ShowSave
Open .FileName For Output As #1
F5.Caption = .FileName
End With
'escribir en el archivo los datos necesaros
Print #1, Text1.Text
'cierra el archivo ya guardado
Close #1
Exit Sub
'en caso de no poder abrir el archivo presenta mensaje de error
manipularerrorguardar:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al guardar el archivo"
End If
End Sub
Public Sub imprimir()
Dim copias As Byte
On Error GoTo manipularerrorimprimir
With CommonDialog
.CancelError = True
.Flags = cdlPDNoSelection Or cdlPDNoPageNums Or cdlPDHidePrintToFile
.PrinterDefault = True
'muestra caja de dialogo imprimir
.ShowPrinter
copias = .Copies
End With
'fijar el numero de copias
Printer.Copies = copias
'tomar el estilo del texto
Printer.Font = Text1.Font
'imprimir el texto actual
Printer.Print Text1.Text
Printer.EndDoc 'fin de la impresion
Exit Sub
'en caso de error al imprimir
manipularerrorimprimir:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "ERROR DESCONOCIDO AL IMPRIMIR"
End If
End Sub
Public Sub fuente()
'procedimiento que modifica el estilo del texto
On Error GoTo manipularerrorfuente
With CommonDialog
.CancelError = True
.FontName = Text1.FontName
.FontSize = Text1.FontSize
.FontBold = Text1.FontBold
.FontItalic = Text1.FontItalic
.FontUnderline = Text1.FontUnderline
.FontStrikethru = Text1.FontStrikethru
.Color = Text1.ForeColor
.Flags = cdlCFBoth Or cdlCFEffects
'muestra el cuadro de dialogo fuente
.ShowFont
End UIT
With CommonDialog
'aplica al cuadro de texto el estilo escogido
Text1.FontName = .FontName
Text1.FontSize = .FontSize
Text1.FontBold = .FontBold
Text1.FontItalic = .FontItalic
Text1.FontUnderline = .FontUnderline
Text1.FontStrikethru = .FontStrikethru
Text1.ForeColor = .Color
End UIT
Exit Sub
'en caso de error al abrir la caja de dialogo de fuente
manipularerrorfuente:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al abrir la caja de dialogo de estilos"
End If
End Sub
Private Sub SALIR_Click()
RS.Close
RV.Close
RAJ.Close
RMAT.Close
DB.Close
Unload Me
End Sub
Private Sub Text1_Change()
modificado = True
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
OPfuente.Enabled = (Text1.SelLength > 0)
End Sub
Public Sub GEN1()
Text1.Text = ""
For a = 1 To 100
Randomize
T = Int(Rnd() * 3 + 1)
Select Case T
Case 1
Do
Randomize
u = Int(Rnd() * 299 + 1)
J = Int(Rnd() * 299 + 1)
Loop While I = J
RS.Seek "=", u
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP
RS.Seek "=", J
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RS!SP
'40000
Text1.Text = Text1.Text & " usar" & " " & P1 & " para producir " & P2 & vbCrLf
Case 2
Do
u = Int(Rnd() * 297 + 1)
J = Int(Rnd() * 297 + 1)
Loop While I = J
RS.Seek "=", u
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP
RS.Seek "=", J
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RS!SP
'40000
Text1.Text = Text1.Text & " reciclar" & " " & P1 & " para producir " & P2 & vbCrLf
Case 3
Do
u = Int(Rnd() * 297 + 1)
J = Int(Rnd() * 297 + 1)
Loop While I = J
RS.Seek "=", u
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP
RS.Seek "=", J
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RS!SP
'40000
Text1.Text = Text1.Text & " vender" & " " & P1 & " para " & P2 & vbCrLf
Case Else
MsgBox " PROBLEMAS EN EL SISTEMA ", vbCritical
Exit Sub
End Select
Next a
End Sub
Public Sub GEN2()
Text1.Text = ""
For a = 1 To 100
Randomize
J = Int(Rnd() * 290 + 1)
'ESTE LOOP PARA EVITAR LOS VERBOS INTRANSITIVOS EN ESTA ESTRUCT
Do
u = Int(Rnd() * 180 + 1)
RV.Seek "=", u
If RV.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
Loop Until RV!TR <> 0
P1 = RV!I 'ASI SE ASEGURA UN VERBO TRANSITIVO
RS.Seek "=", J
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RS!SP 'ESCOGE UN S EN PLURAL 40x40=1600, 3200
'60000
Text1.Text = Text1.Text & " " & P1 & " " & P2 & vbCrLf
Next a
End Sub
Public Sub GEN3()
Text1.Text = ""
'ESCRIBE 100 IDEAS
For a = 1 To 100
Randomize
J = Int(Rnd() * 297 + 1)
'ESTE LOOP PARA EVITAR LOS VERBOS INTRANSITIVOS EN ESTA ESTRUCT
Do
u = Int(Rnd() * 180 + 1)
RV.Seek "=", u
If RV.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
Loop Until RV!TR <> 0
P1 = RV!G 'ASI SE ASEGURA UN VERBO TRANSITIVO
RS.Seek "=", J
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RS!SP 'ESCOGE UN S EN PLURAL 40x40=1600, 3200
'60000
Text1.Text = Text1.Text & " " & "negociar " & P1 & " " & P2 & vbCrLf
Next a
End Sub
Public Sub GEN4()
Text1.Text = ""
'ESCRIBE 100 IDEAS
For a = 1 To 100
Randomize
'ESTE LOOP PARA EVITAR LOS VERBOS INTRANSITIVOS EN ESTA ESTRUCT
Do
u = Int(Rnd() * 180 + 1)
RV.Seek "=", u
If RV.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
Loop Until RV!TR <> 0
P1 = RV!I 'ASI SE ASEGURA UN VERBO TRANSITIVO
Text1.Text = Text1.Text & " " & "enseñar a " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN5()
Text1.Text = ""
For a = 1 To 100
Randomize
J = Int(Rnd() * 297 + 1)
RS.Seek "=", J
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ESCOGE UN AJ 40x40=1600, 3200
If RS!M = True Then
u = Int(Rnd() * 110 + 1)
RAJ.Seek "=", u
If RAJ.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RAJ!PM
Else
If RS!M = False Then
u = Int(Rnd() * 110 + 1)
RAJ.Seek "=", u
If RAJ.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RAJ!PF
End If
End If
'300*110
Text1.Text = Text1.Text & " diseñar una fabrica de " & P1 & " " & P2 & vbCrLf
Next a
End Sub
Public Sub GEN6() '2000+
Dim TXT1(11) As String
Dim u1 As Integer
Text1.Text = ""
'ESCRIBE 100 IDEAS
TXT1(1) = "vender maquinas que sirvan para":
TXT1(2) = "producir motores que sirvan para":
TXT1(3) = "ofrecer equipos que sirvan para":
TXT1(4) = "alquilar lugares para":
TXT1(5) = "ofrecer cursos para aprender a":
TXT1(6) = "alquilar ropa para":
TXT1(7) = "enseñar a":
TXT1(8) = "vender herramientas para":
TXT1(9) = "vender accesorios para":
TXT1(10) = "vender implementos para":
TXT1(11) = "vender productos quimicos para":
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 11 + 1)
u = Int(Rnd() * 180 + 1)
RV.Seek "=", u
If RV.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RV!I 'ASI SE ASEGURA UN VERBO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN7()
Dim TXT1(21) As String
Dim u1 As Integer
Text1.Text = ""
'ESCRIBE 100 IDEAS
TXT1(1) = "vender exhibidores para":
TXT1(2) = "vender seguros para":
TXT1(3) = "enseñar a usar":
TXT1(4) = "reciclar":
TXT1(5) = "enseñar a reutilizar":
TXT1(6) = "vender":
TXT1(7) = "fabricar":
TXT1(8) = "vender equipos para fabricar":
TXT1(9) = "producir empaques para":
TXT1(10) = "vender materiales para fabricar":
TXT1(11) = "producir partes para ensamblar":
TXT1(12) = "vender repuestos para":
TXT1(13) = "vender accesorios para":
TXT1(14) = "ofrecer transporte para":
TXT1(15) = "producir juguetes en forma de":
TXT1(16) = "producir golosinas en forma de":
TXT1(17) = "producir embalaje para":
TXT1(18) = "alquilar":
TXT1(19) = "rentar bodegas para":
TXT1(20) = "enseñar a hacer":
TXT1(21) = "vender alarmas para":
'TXT1(11) = "":
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 21 + 1)
u = Int(Rnd() * 297 + 1)
RS.Seek "=", u
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN8()
Dim TXT1(4) As String
Dim u1 As Integer
Text1.Text = ""
TXT1(1) = "ofrecer capacitacion para"
TXT1(2) = "enseñar a"
TXT1(3) = "vender informacion para"
TXT1(4) = "asesorar para"
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 4 + 1)
u = Int(Rnd() * 297 + 1)
RS.Seek "=", u
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
Do
u = Int(Rnd() * 180 + 1)
RV.Seek "=", u
If RV.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
Loop Until RV!TR <> 0
P2 = RV!I 'ASI SE ASEGURA UN VERBO TRANSITIVO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P2 & " " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN9()
Dim TXT1(4) As String
Dim u1 As Integer
Text1.Text = ""
TXT1(1) = "servir"
TXT1(2) = "negociar"
TXT1(3) = "trabajar"
TXT1(4) = "ayudar"
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 4 + 1)
u = Int(Rnd() * 297 + 1)
RS.Seek "=", u
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
Do
u = Int(Rnd() * 180 + 1)
RV.Seek "=", u
If RV.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
Loop Until RV!TR <> 0
P2 = RV!G 'ASI SE ASEGURA UN VERBO TRANSITIVO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P2 & " " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN10()
Dim TXT1(5), TXT2(3) As String
Dim u1, u2, u3, u4 As Integer
Text1.Text = ""
TXT1(1) = "vender"
TXT1(2) = "producir"
TXT1(3) = "diseñar"
TXT1(4) = "elaborar"
TXT1(5) = "fabricar"
TXT2(1) = "que tengan"
TXT2(2) = "con"
TXT2(3) = "y"
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 5 + 1)
u2 = Int(Rnd() * 3 + 1)
Do
Randomize
u3 = Int(Rnd() * 297 + 1)
u4 = Int(Rnd() * 297 + 1)
Loop Until u3 <> u4 'GENERA CODIGOS DIFERENTES
RS.Seek "=", u3
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
RS.Seek "=", u4
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RS!SP 'ASI SE ASEGURA OTRO SUSTANTIVO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P1 & " " & TXT2(u2) & " " & P2 & vbCrLf
Next a
End Sub
Private Sub Timer1_Timer()
Call DISPLAY_WORD
End Sub
Public Sub DISPLAY_WORD() ‘muestra la palabra de Dios,
Dim W(32), V(32) As String ‘fuente de todo lo que existe
Dim I, J, K, l, M, n As Integer ‘en el cielo, la tierra y el mar
Dim E(32) As Boolean
K = 0
'INICIALIZA CON NINGUNO HA SIDO ESCOGIDO
For I = 1 To 32
E(I) = False
Next I
'LOS VERSOS DE LA BIBLIA
W(1) = "EL RESPONDIÓ Y DIJO: ESCRITO ESTÁ: NO SÓLO DE PAN VIVIRÁ EL HOMBRE, SINÓ DE TODA PALABRA QUE SALE DE LA BOCA DE DIOS. ": V(1) = "MATEO 4:4"
W(2) = "EL CIELO Y LA TIERRA PASARÁN, PERO MIS PALABRAS NO PASARÁN. ": V(2) = "MARCOS 13:31"
W(3) = "Y TODOS DABAN BUEN TESTIMONO DE ÉL Y ESTABAN MARAVILLADOS DE LAS PALABRAS QUE SALÍAN DE SU BOCA, Y DECÍAN ¿ NO ES ÉSTE EL HIJO DE JOSÉ ? ": V(3) = "LUCAS 4:22"
W(4) = "Y SE ADMIRABAN DE SU DOCTRINA PORQUE SU PALABRA ERA CON AUTORIDAD.": V(4) = "LUCAS 4:32"
W(5) = "EL ESPIRITU ES EL QUE DA VIDA; LA CARNE PARA NADA APROVECHA; LAS PALABRAS QUE OS HE HABLADO SON ESPÍRITU Y SON VIDA": V(5) = "JUAN 6:63"
W(6) = "LE RESPONDIÓ SIMÓN PEDRO: SEÑOR ¿ A QUIÉN IREMOS ?, TÚ TIENES PALABRAS DE VIDA ETERNA.": V(6) = "JUAN 6:68"
W(7) = "LOS ALGUACILES RESPONDIERON: ¡ JAMÁS HOMBRE ALGUNO HA HABLADO COMO ÉSTE HOMBRE !": V(7) = "JUAN 7:46"
W(8) = "EL QUE ME RECHAZA, Y NO RECIBE MIS PALABRAS, TIENE QUIEN LE JUZGUE; LA PALABRA QUE HE HABLADO, ELLA LE JUZGARÁ EN EL DÍA POSTRERO.": V(8) = "JUAN 12:48"
W(9) = "EL QUE NO ME AMA, NO GUARDA MIS PALABRAS; Y LA PALABRA QUE HABÉIS OÍDO NO ES MÍA SINÓ DEL PADRE QUE ME ENVIÓ.": V(9) = "JUAN 14:24"
W(10) = "DE CIERTO, DE CIERTO OS DIGO, QUE EL QUE GUARDA MIS PALABRA, NUNCA VERÁ MUERTE. ": V(10) = "JUAN 8:51"
W(11) = "Y bendito sea el Dios altísimo, que entregó tus enemigos en tu mano. Y le dio Abram los diezmos de todo.": V(11) = "Génesis 14:20"
W(12) = "Y esta piedra que he puesto por señal, será casa de Dios; y de todo lo que me dieres, el diezmo apartaré para ti.": V(12) = "Génesis 28:22"
W(13) = "Y el diezmo de la tierra, así de la simiente de la tierra como del fruto de los árboles, de Jehová es; es cosa dedicada a Jehová.": V(13) = "Levítico 27:30"
W(14) = "Y cuando este edicto fue divulgado, los hijos de Israel dieron muchas primicias de grano, vino, aceite, miel, y de todos los frutos de la tierra; trajeron asimismo en abundancia los diezmos de todas las cosas. ": V(14) = "2 Crónicas 31:5"
W(15) = "Traed todos los diezmos al alfolí y haya alimento en mi casa; y probadme ahora en esto, dice Jehová de los ejércitos, si no os abriré las ventanas de los cielos y derramaré sobre vosotros bendición hasta que sobreabunde.": V(15) = "Malaquías 3:10"
W(16) = "Y cuando tu hermano empobreciere y se acogiere a ti, tú lo ampararás; como forastero y extrangero vivirá contigo.": V(16) = "Levítico 25:35"
W(17) = "Cuando haya en medio de ti menesteroso de alguno de tus hermanos en alguna de tus ciudades, en la tierra que Jehová tu Dios te dá, no endurecerás tu corazón, ni cerrarás tu mano contra tu hermano pobre.": V(17) = "Deuteronomio 15:7"
W(18) = "Guardaos de hacer vuestra justicia delante de los hombres, para ser vistos de ellos; de otra manera no tendréis recompensa de vuestro padre que está en los cielos.": V(18) = "Mateo 6:1"
W(19) = "Jesús le dijo: Si quieres ser perfecto, vende lo que tienes, y dalo a los pobre, y tendrás tesoro en el cielo; y ven y sígueme.": V(19) = "Mateo 19:21"
W(20) = "Pero dad limosna de lo que tenéis, y entonces todo os será limpio.": V(20) = "Lucas 11:41"
W(21) = "Hay quienes reparten y les es añadido más; y hay quienes retienen mas de lo que es justo pero vienen a pobreza.": V(21) = "Proverbios 11:24"
W(22) = "El que cierra su oído al clamor del pobre, También él clamará y no será oído.": V(22) = "Proverbios 21:13"
W(23) = "El que dá al pobre no tendrá pobreza; Mas el que aparta sus ojos tendrá muchas maldiciones.": V(23) = "Proverbios 28:27"
W(24) = "Hay un mal doloroso que he visto debajo del sol: Las riquezas guardadas por sus dueños para su mal.": V(24) = "Eclesiastés 5:13"
W(25) = "Vino a él una mujer, con un vaso de alabastro de perfume de gran precio, y lo derramó sobre la cabeza de él, estando sentado a la mesa.": V(25) = "Mateo 26:7"
W(26) = "¿Robará el hombre a Dios? Pues vosotros me habéis robado. Y dijisteis: ¿en qué te hemos robado? En vuestros diezmos y ofrendas. ": V(26) = "Malaquías 3:8"
W(27) = "No codiciarás la casa de tu prójimo, no codiciarás la mujer de tu prójimo, ni su siervo, ni su criada, ni su buey, ni su asno, ni cosa alguna de tu prójimo.": V(27) = "Exodo 20:17"
W(28) = "Porque desde el más chico de ellos hasta el más grande, cada uno sigue la avaricia; y desde el profeta hasta el sacerdote, todos son engañadores.": V(28) = "Jeremías 6:13"
W(29) = "¡Ay del que codicia injusta ganancia para su casa, para poner en alto su nido, para escaparse del poder del mal! ": V(29) = "Habacuc 2:9"
W(30) = "Y les dijo: Mirad y guardaos de toda avaricia; porque la vida del hombre no consiste en la abundancia de los bienes que posee. ": V(30) = "Lucas 12:15"
W(31) = "Haced morir, pues, lo terrenal en vosotros: fornicación, impureza, pasiones desordenadas, malos deseos y avaricia, que es idolatría;": V(31) = "Colosenses 3:5"
W(32) = "Alborota su casa el codicioso; mas el que aborrece el soborno vivirá.": V(32) = "Proverbios 15:27"
Text2.Text = ""
Label1.Caption = ""
Randomize
'PRODUCE UN ENTERO I
Do
I = Int(Rnd() * 32 + 1)
Loop Until E(I) = False 'VERIFICA QUE NO HA SIDO ESCOGIDO
'DISPLAYA EL VERSO CORRESPONDIENTE
Text2.Text = Text2.Text & W(I)
Label1.Caption = Label1.Caption & V(I)
E(I) = True
K = K + 1 'CONTADOR
'CUANDO HAY 32 VERSOS DISPLAYADOS
'HACE QUE NINGUNO FUE ESCOGIDO
If K = 32 Then
For I = 1 To 32
E(I) = False
Next I
K = 0 'REINICIALIZA
End If
End Sub
Public Sub GEN11()
Dim TXT1(8), TXT2(3) As String
Dim u1, u2, u3, u4 As Integer
Text1.Text = ""
TXT1(1) = "dar mantenimiento a"
TXT1(2) = "dar limpieza a"
TXT1(3) = "dar mejoras a"
TXT1(4) = "vender repuestos para"
TXT1(5) = "vender accesorios para"
TXT1(6) = "instalar repuestos a"
TXT1(7) = "adornar"
TXT1(8) = "instalar repuestos para"
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 8 + 1)
u2 = Int(Rnd() * 297 + 1)
RS.Seek "=", u2
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN12()
Dim TXT1(8), TXT2(3) As String
Dim u1, u2, u3, u4 As Integer
Text1.Text = ""
TXT1(1) = "elaborar"
TXT1(2) = "hacer"
TXT1(3) = "construir"
TXT1(4) = "fabricar"
TXT1(5) = "diseñar"
TXT1(6) = "armar"
TXT1(7) = "vender"
TXT1(8) = "negociar con"
TXT2(1) = "que puedan"
TXT2(2) = "que ayuden a"
TXT2(3) = "para"
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 8 + 1)
u2 = Int(Rnd() * 3 + 1)
Randomize
u3 = Int(Rnd() * 297 + 1)
u4 = Int(Rnd() * 180 + 1)
RS.Seek "=", u3
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
RV.Seek "=", u4
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RV!I 'ASI SE ASEGURA UN VERBO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P1 & " " & TXT2(u2) & " " & P2 & vbCrLf
Next a
End Sub
Public Sub GEN13()
Dim TXT1(6) As String
Dim u, u1 As Integer
TXT1(1) = "elaborar"
TXT1(2) = "hacer"
TXT1(3) = "construir"
TXT1(4) = "fabricar"
TXT1(5) = "diseñar"
TXT1(6) = "armar"
Text1.Text = ""
'ESCRIBE 100 IDEAS
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 6 + 1)
J = Int(Rnd() * 297 + 1)
RS.Seek "=", J
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP
'ESCOGE UN AJ
u = Int(Rnd() * 110 + 1)
RAJ.Seek "=", u
If RAJ.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
If RS!M = True Then
P2 = RAJ!PM
Else
P2 = RAJ!PF
End If
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P1 & " " & P2 & vbCrLf
Next a
End Sub
Public Sub GEN14()
Dim TXT1(2), TXT2(2), PROF(30) As String
Dim u, u1, u2, u3 As Integer
Text1.Text = ""
TXT1(1) = "trabajar"
TXT1(2) = "negociar"
TXT2(1) = "a"
TXT2(2) = "para"
PROF(1) = "doctores"
PROF(2) = "abogados"
PROF(3) = "profesores"
PROF(4) = "pintores"
PROF(5) = "choferes"
PROF(6) = "mensajeros"
PROF(7) = "gerentes"
PROF(8) = "rectores"
PROF(9) = "administradores"
PROF(10) = "masajistas"
PROF(11) = "despachadores"
PROF(12) = "vendedores"
PROF(13) = "amas de casa"
PROF(14) = "camareros"
PROF(15) = "nadadores"
PROF(16) = "deportistas"
PROF(17) = "viajeros"
PROF(18) = "turistas"
PROF(19) = "dibujantes"
PROF(20) = "entrenadores"
PROF(21) = "constructores"
PROF(22) = "ferreteros"
PROF(23) = "electricistas"
PROF(24) = "farmaceuticos"
PROF(25) = "ingenieros"
PROF(26) = "artesanos"
PROF(27) = "periodistas"
PROF(28) = "cocineros"
PROF(29) = "costureras"
PROF(30) = "comerciantes"
'PROF() = ""
For a = 1 To 100
Randomize
u1 = Int(Rnd() * 2 + 1)
u2 = Int(Rnd() * 2 + 1)
u3 = Int(Rnd() * 30 + 1)
u = Int(Rnd() * 180 + 1)
RV.Seek "=", u
If RV.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RV!G 'ASI SE ASEGURA UN VERBO EN GERUNDIO
Text1.Text = Text1.Text & " " & TXT1(u1) & " " & P1 & " " & TXT2(u2) & " " & PROF(u3) & vbCrLf
Next a
End Sub
Public Sub GEN15()
Dim E(26), P(2) As String
Dim u, u1, u2, u3, a, I As Integer
Text1.Text = ""
P(1) = "fabricar"
P(2) = "vender"
E(1) = "tarjetas de"
E(2) = "sellos de"
E(3) = "relojes de"
E(4) = "tuberia de"
E(5) = "rotulos de"
E(6) = "muebles de"
E(7) = "cortinas de"
E(8) = "carros de"
E(9) = "empaques de"
E(10) = "bebidas en envases de"
E(11) = "envases de"
E(12) = "tanques de"
E(13) = "tejidos de"
E(14) = "puertas de"
E(15) = "botellas de"
E(16) = "botones de"
E(17) = "bordados de"
E(18) = "cajas de"
E(19) = "rollos de"
E(20) = "laminas de"
E(21) = "estructuras de"
E(22) = "encuadernacion con"
E(23) = "cuadernos de"
E(24) = "carpetas de"
E(25) = "anillos de"
E(26) = "perfiles de"
For a = 1 To 100
Randomize
u = Int(Rnd() * 99 + 1)
u1 = Int(Rnd() * 2 + 1)
u2 = Int(Rnd() * 26 + 1)
RMAT.Seek "=", u
If RMAT.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RMAT!MAT
Text1.Text = Text1.Text & " " & P(u1) & " " & E(u2) & " " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN16()
Dim P(3) As String
Dim u, u1, u2, u3, a, I As Integer
Text1.Text = ""
P(1) = "fabricar"
P(2) = "vender"
P(3) = "enseñar a trabajar con"
For a = 1 To 100
Randomize
u = Int(Rnd() * 99 + 1)
u1 = Int(Rnd() * 3 + 1)
RMAT.Seek "=", u
If RMAT.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RMAT!MAT
Text1.Text = Text1.Text & " " & P(u1) & " " & P1 & vbCrLf
Next a
End Sub
Public Sub GEN17()
Dim P(2), P1, P2 As String
Dim u, u1, u2, u3, a, I As Integer
Text1.Text = ""
P(1) = "fabricar"
P(2) = "vender"
For a = 1 To 100
Randomize
u = Int(Rnd() * 99 + 1)
u1 = Int(Rnd() * 2 + 1)
u2 = Int(Rnd() * 297 + 1)
RMAT.Seek "=", u
If RMAT.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RMAT!MAT
RS.Seek "=", u2
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
Text1.Text = Text1.Text & " " & P(u1) & " " & P1 & " de " & P2 & vbCrLf
Next a
End Sub
Public Sub GEN18()
Dim P(4), T(4), P1, P2 As String
Dim u, u1, u2, u3, a, I As Integer
Text1.Text = ""
P(1) = "fabricar"
P(2) = "vender"
P(3) = "producir accesorios para"
P(4) = "enseñar a hacer"
T(1) = "con"
T(2) = "de"
For a = 1 To 100
Randomize
u = Int(Rnd() * 99 + 1) 'P2 MAT
u1 = Int(Rnd() * 4 + 1) 'P()
u2 = Int(Rnd() * 297 + 1) 'P1
u3 = Int(Rnd() * 2 + 1) 'T()
RMAT.Seek "=", u
If RMAT.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P2 = RMAT!MAT
RS.Seek "=", u2
If RS.NoMatch Then
MsgBox "CODIGO NO EXISTE", 16
Exit Sub
End If
P1 = RS!SP 'ASI SE ASEGURA UN SUSTANTIVO
Text1.Text = Text1.Text & " " & P(u1) & " " & P1 & " " & T(u3) & " " & P2 & vbCrLf
Next a
End Sub
‘formulario F1 Notas
Dim C(16), V(12), G(6), K(8), l(3), F(9) As String
Private Sub Form_Load()
Aplicar3_skin Me
End Sub
Private Sub MENUIMPRIMIR_Click()
Call imprimir
End Sub
Private Sub OPabrir_Click()
Call abrir
End Sub
Private Sub OPfuente_Click()
Call fuente
End Sub
Private Sub OPguardarcomo_Click()
Call guardarcomo
End Sub
Private Sub OPnuevo_Click()
F1.Caption = " ( Sin Título ) "
Text1.Text = ""
End Sub
Private Sub OPsalir_Click()
Unload Me
End Sub
'sub para abrir un archivo de texto
Public Sub abrir()
On Error GoTo manipularerrorabrir
'muestra la caja de dialogo abrir archivo
With CommonDialog1
.Filter = "ARCHIVOS DE TEXTO*.TXTTodos los Archivos*.*"
.DefaultExt = ".txt"
.ShowOpen
Open .FileName For Input As #1
F1.Caption = .FileName
End With
'limpia la caja de texto
Text1.Text = ""
'abre el archivo con las caracteristicas de texto previas
Text1.Text = Input$(LOF(1), #1)
Close #1
Exit Sub
''mensaje de error si no puede abrir el archivo
manipularerrorabrir:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al abrir el archivo"
End If
End Sub
Public Sub guardarcomo()
On Error GoTo manipularerrorguardar
With CommonDialog1
.CancelError = True
.DefaultExt = ".txt"
.Filter = "TEXTO*.TXTTodos los Archivos*.*"
'muestra mensaje si desea sobreescribir en el archivo
.Flags = cdlOFNOverwritePrompt
.ShowSave
Open .FileName For Output As #1
F1.Caption = .FileName
End With
'escribir en el archivo los datos necesaros
Print #1, Text1.Text
'cierra el archivo ya guardado
Close #1
Exit Sub
'en caso de no poder abrir el archivo presenta mensaje de error
manipularerrorguardar:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al guardar el archivo"
End If
End Sub
Public Sub imprimir()
Dim copias As Byte
On Error GoTo manipularerrorimprimir
With CommonDialog1
.CancelError = True
.Flags = cdlPDNoSelection Or cdlPDNoPageNums Or cdlPDHidePrintToFile
.PrinterDefault = True
'muestra caja de dialogo imprimir
.ShowPrinter
copias = .Copies
End With
'fijar el numero de copias
Printer.Copies = copias
'tomar el estilo del texto
Printer.Font = Text1.Font
'imprimir el texto actual
Printer.Print Text1.Text
Printer.EndDoc 'fin de la impresion
Exit Sub
'en caso de error al imprimir
manipularerrorimprimir:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "ERROR DESCONOCIDO AL IMPRIMIR"
End If
End Sub
Public Sub fuente()
'procedimiento que modifica el estilo del texto
On Error GoTo manipularerrorfuente
With CommonDialog1
.CancelError = True
.FontName = Text1.FontName
.FontSize = Text1.FontSize
.FontBold = Text1.FontBold
.FontItalic = Text1.FontItalic
.FontUnderline = Text1.FontUnderline
.FontStrikethru = Text1.FontStrikethru
.Color = Text1.ForeColor
.Flags = cdlCFBoth Or cdlCFEffects
'muestra el cuadro de dialogo fuente
.ShowFont
End With
With CommonDialog1
'aplica al cuadro de texto el estilo escogido
Text1.FontName = .FontName
Text1.FontSize = .FontSize
Text1.FontBold = .FontBold
Text1.FontItalic = .FontItalic
Text1.FontUnderline = .FontUnderline
Text1.FontStrikethru = .FontStrikethru
Text1.ForeColor = .Color
End With
Exit Sub
'en caso de error al abrir la caja de dialogo de fuente
manipularerrorfuente:
If Err.Number = 32755 Then
Exit Sub
Else
MsgBox "error al abrir la caja de dialogo de estilos"
End If
End Sub
Private Sub Text1_Change()
modificado = True
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
OPfuente.Enabled = (Text1.SelLength > 0)
End Sub
‘formulario DATOS
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Command2_Click() 'BOTON VER
DATOS.Hide
Form1.Show
Form1.MSChart1.TitleText = T1.Text
With Form1.MSChart1
.ShowLegend = True
.ColumnCount = 4
.RowCount = 3
.Column = 1
.Row = 1
.RowLabel = FLXGRID.TextMatrix(1, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 1)
.Data = Val(FLXGRID.TextMatrix(1, 1))
.Column = 1
.Row = 2
.RowLabel = FLXGRID.TextMatrix(2, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 1)
.Data = Val(FLXGRID.TextMatrix(2, 1))
.Column = 1
.Row = 3
.RowLabel = FLXGRID.TextMatrix(3, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 1)
.Data = Val(FLXGRID.TextMatrix(3, 1))
.Column = 2
.Row = 1
.RowLabel = FLXGRID.TextMatrix(1, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 2)
.Data = Val(FLXGRID.TextMatrix(1, 2))
.Column = 2
.Row = 2
.RowLabel = FLXGRID.TextMatrix(2, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 2)
.Data = Val(FLXGRID.TextMatrix(2, 1))
.Column = 2
.Row = 3
.RowLabel = FLXGRID.TextMatrix(3, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 2)
.Data = Val(FLXGRID.TextMatrix(3, 2))
.Column = 3
.Row = 1
.RowLabel = FLXGRID.TextMatrix(1, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 3)
.Data = Val(FLXGRID.TextMatrix(1, 3))
.Column = 3
.Row = 2
.RowLabel = FLXGRID.TextMatrix(2, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 3)
.Data = Val(FLXGRID.TextMatrix(2, 3))
.Column = 3
.Row = 3
.RowLabel = FLXGRID.TextMatrix(3, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 3)
.Data = Val(FLXGRID.TextMatrix(3, 3))
.Column = 4
.Row = 1
.RowLabel = FLXGRID.TextMatrix(1, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 4)
.Data = Val(FLXGRID.TextMatrix(1, 4))
.Column = 4
.Row = 2
.RowLabel = FLXGRID.TextMatrix(2, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 4)
.Data = Val(FLXGRID.TextMatrix(2, 4))
.Column = 4
.Row = 3
.RowLabel = FLXGRID.TextMatrix(3, 0)
.ColumnLabel = FLXGRID.TextMatrix(0, 4)
.Data = Val(FLXGRID.TextMatrix(3, 4))
End With
End Sub
Private Sub FLXGRID_EnterCell()
Text1.Text = ""
Text1.Visible = False
Text1.Top = FLXGRID.Top + FLXGRID.CellTop
Text1.Left = FLXGRID.Left + FLXGRID.CellLeft
Text1.Width = FLXGRID.CellWidth
Text1.Height = FLXGRID.CellHeight
Text1.Text = FLXGRID.Text
Text1.Visible = True
Text1.SetFocus
End Sub
Private Sub FLXGRID_LeaveCell()
FLXGRID.Text = Text1.Text
End Sub
Private Sub Form_Load()
FLXGRID.TextMatrix(0, 1) = "producto 1"
FLXGRID.TextMatrix(0, 2) = "producto 2"
FLXGRID.TextMatrix(0, 3) = "producto 3"
FLXGRID.TextMatrix(0, 4) = "producto 4"
FLXGRID.TextMatrix(1, 0) = "Enero"
FLXGRID.TextMatrix(2, 0) = "febrero"
FLXGRID.TextMatrix(3, 0) = "Marzo"
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case 13
FLXGRID.Row = FLXGRID.RowSel + 1
FLXGRID.Col = FLXGRID.ColSel
Case 32
FLXGRID.Row = FLXGRID.RowSel
FLXGRID.Col = FLXGRID.ColSel + 1
Case 8
If FLXGRID.RowSel <> 0 Then
FLXGRID.Row = FLXGRID.RowSel - 1
FLXGRID.Col = FLXGRID.ColSel
Else
Exit Sub
End If
End Select
End Sub
‘formulario COSTOS
Dim DB As Database
Dim rc As Recordset
Dim RP As Recordset
Dim COSTOS(12) As Double
Dim CANTSOLIC, COSTOTOTL, PVPSUGER, PORCENDUTIL As Double
Dim PVPFINAL, COSTOUNIT, UTILNETA As Double
Private Sub CANTS_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub CMDCALCULARCOSTOS_Click()
Call VERIFICACION2
COSTOS(1) = Val(T1.Text)
COSTOS(2) = Val(T2.Text)
COSTOS(3) = Val(T3.Text)
COSTOS(4) = Val(T4.Text)
COSTOS(5) = Val(T5.Text)
COSTOS(6) = Val(T6.Text)
COSTOS(7) = Val(T7.Text)
COSTOS(8) = Val(T8.Text)
COSTOS(9) = Val(T9.Text)
COSTOS(10) = Val(T10.Text)
COSTOS(11) = Val(T11.Text)
COSTOS(12) = Val(T12.Text)
COSTOUNIT = 0
For I = 1 To 12
COSTOUNIT = COSTOUNIT + COSTOS(I)
Next I
Call CALCULARLOSCOSTOS
CMDCALCULARCOSTOS.Enabled = False
End Sub
Private Sub CALCULARLOSCOSTOS()
CU.Text = COSTOUNIT
CTT.Text = Val(CANTS) * COSTOUNIT
PVPS = 2.5 * Val(CTT)
PVPSUGER = Val(PVPS.Text)
PVP.Text = Val(CTT.Text) * Val(PERUT) / 100 + Val(CTT.Text)
UTNT.Text = Val(PVP.Text) - Val(CTT.Text)
If Val(CANTS) = 0 Then
MsgBox "INGRESE LA CANTIDAD", vbCritical
CANTS.SetFocus
Exit Sub
Else
PVPUNIT.Text = Val(PVP) / Val(CANTS)
End If
End Sub
Private Sub CMDCONSULTAR_Click()
If TCOD.Text = "" Then
MsgBox "INGRESE CODIGO", 16
TCOD.SetFocus
Exit Sub
End If
rc.Seek "=", TCOD.Text
If rc.NoMatch Then
MsgBox "EL CODIGO NO EXISTE", 16
TCOD = ""
TCOD.SetFocus
Exit Sub
End If
TXTPROY.Text = rc!PROYECTO
LBL1.Text = rc!IN1
LBL2.Text = rc!IN2
LBL3.Text = rc!IN3
LBL4.Text = rc!IN4
LBL5.Text = rc!IN5
LBL6.Text = rc!IN6
LBL7.Text = rc!IN7
LBL8.Text = rc!IN8
LBL9.Text = rc!IN9
LBL10.Text = rc!IN10
LBL11.Text = rc!IN11
LBL12.Text = rc!IN12
CMDCALCULARCOSTOS.Enabled = True
End Sub
Private Sub CMDGUARDAR_Click()
Call VERIFICACION2
RP.AddNew
RP!N_ORDEN = textnumord.Text
RP!NOMCLIENTE = TEXTCLI.Text
RP!NOMPROYECTO = TXTPROY.Text
RP!CANTPROYS = CANTS
RP!PVP = Val(PVP.Text)
RP!UTILIDAD = Val(UTNT.Text)
RP!INGRESO = Val(PVP.Text)
RP!EGRESO = Val(CTT.Text)
RP!COSTOU = Val(CTT.Text) / Val(CANTS.Text)
RP!PORCENUTILIDAD = Val(PERUT.Text)
RP.Update
Call LMP
Data1.Refresh
Data1.Recordset.MoveLast
textnumord.Text = Val(Text1.Text) + 1
End Sub
Private Sub LMP()
T1 = "-"
T2 = "-"
T3 = "-"
T4 = "-"
T5 = "-"
T6 = "-"
T7 = "-"
T8 = "-"
T9 = "-"
T10 = "-"
T11 = "-"
T12 = "-"
LBL1 = "-"
LBL2 = "-"
LBL3 = "-"
LBL4 = "-"
LBL5 = "-"
LBL6 = "-"
LBL7 = "-"
LBL8 = "-"
LBL9 = "-"
LBL10 = "-"
LBL11 = "-"
LBL12 = "-"
TEXTCLI.Text = ""
PVPUNIT.Text = ""
TXTPROY.Text = ""
Call INICOSTOS
Call INITXTFINANCIEROS
CMDCONSULTAR.SetFocus
End Sub
Private Sub INITXTFINANCIEROS()
TCOD = ""
CANTS = ""
CTT = ""
PVP = ""
PVPS = ""
PERUT = ""
UTNT = ""
CU = ""
End Sub
Private Sub CMDSALIR_Click()
Data1.Refresh
rc.Close
RP.Close
DB.Close
Unload Me
BASE_MANUFACTURAS.Command3.Visible = True
End Sub
Private Sub CMDSELECCIONARCODIGO_Click()
BASE_MANUFACTURAS.Show
BASE_MANUFACTURAS.Command3.Visible = False
End Sub
Private Sub INICOSTOS()
T1 = 0
T2 = 0
T3 = 0
T4 = 0
T5 = 0
T6 = 0
T7 = 0
T8 = 0
T9 = 0
T10 = 0
T11 = 0
T12 = 0
End Sub
Private Sub Form_Load()
Set DB = OpenDatabase(App.Path & "IND.mdb")
Set rc = DB.OpenRecordset("PROYECTOS")
rc.Index = "I_PROYECTOS"
Set RP = DB.OpenRecordset("PRODUCCIONES")
RP.Index = "I_PRODUCCIONES"
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "PRODUCCIONES"
Data1.Refresh
Call INICOSTOS
CMDCALCULARCOSTOS.Enabled = False
Data1.Refresh
Data1.Recordset.MoveLast
textnumord.Text = Val(Text1.Text) + 1
End Sub
Private Sub PERUT_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
If KeyAscii = 13 Then
If CANTS.Text = "" Then
MsgBox "DEBE ESCRIBIR LA CANTIDAD SOLICITADA", 16
CANTS.SetFocus
Exit Sub
End If
CMDCALCULARCOSTOS.Enabled = True
End If
End Sub
Private Sub T1_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T10_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T11_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T12_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T2_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T3_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T4_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T5_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T6_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T7_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T8_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub T9_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub TCOD_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub TEXTCLI_KeyPress(KeyAscii As Integer)
Call VAL_T(KeyAscii)
If KeyAscii = 13 Then
TEXTCLI.Text = UCase(TEXTCLI.Text)
End If
End Sub
Private Sub textnumord_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Public Sub VERIFICACION2()
If T1 = "" Then
MsgBox "FALTA COSTO", 16
T1.SetFocus
Exit Sub
End If
If T2 = "" Then
MsgBox "FALTA COSTO", 16
T2.SetFocus
Exit Sub
End If
If T3 = "" Then
MsgBox "FALTA COSTO", 16
T3.SetFocus
Exit Sub
End If
If T4 = "" Then
MsgBox "FALTA COSTO", 16
T4.SetFocus
Exit Sub
End If
If T5 = "" Then
MsgBox "FALTA COSTO", 16
T5.SetFocus
Exit Sub
End If
If T6 = "" Then
MsgBox "FALTA COSTO", 16
T6.SetFocus
Exit Sub
End If
If T7 = "" Then
MsgBox "FALTA COSTO", 16
T7.SetFocus
Exit Sub
End If
If T8 = "" Then
MsgBox "FALTA COSTO", 16
T8.SetFocus
Exit Sub
End If
If T9 = "" Then
MsgBox "FALTA COSTO", 16
T9.SetFocus
Exit Sub
End If
If T10 = "" Then
MsgBox "FALTA COSTO", 16
T10.SetFocus
Exit Sub
End If
If T11 = "" Then
MsgBox "FALTA COSTO", 16
T11.SetFocus
Exit Sub
End If
If T12 = "" Then
MsgBox "FALTA COSTO", 16
T12.SetFocus
Exit Sub
End If
If TCOD = "" Then
MsgBox "ESCRIBA EL CODIGO", 16
TCOD.SetFocus
Exit Sub
End If
If TEXTCLI = "" Then
MsgBox "ESCRIBA EL NOMBRE DEL CLIENTE", 16
TEXTCLI.SetFocus
Exit Sub
End If
If CANTS = "" Then
MsgBox "FALTA LA CANTIDAD", 16
CANTS.SetFocus
Exit Sub
End If
If PERUT = "" Then
MsgBox "ESCRIBA EL PORCENTAJE DE UTILIDAD", 16
PERUT.SetFocus
Exit Sub
End If
If TXTPROY = "" Then
MsgBox "ESCOJA UN PROYECTO", 16
TXTPROY.SetFocus
Exit Sub
End If
If textnumord = "" Then
MsgBox "ESCRIBA EL NUMERO DE LA ORDEN DE PRODUCCION", 16
textnumord.SetFocus
Exit Sub
End If
End Sub
‘formulario de consulta de reportes CONSULTAREP
Private Sub Command1_Click() 'PRIMERO
If Not Data1.Recordset.BOF Then
Command1.Enabled = True
Data1.Recordset.MoveFirst
End If
If Data1.Recordset.BOF Then
Data1.Recordset.MoveFirst
Command2.Enabled = True 'BTN AVANZAR
Command3.Enabled = False 'BTN ATRAS
End If
Call ACT
End Sub
Private Sub Command2_Click() 'AVANZAR
If Not Data1.Recordset.EOF Then
Command2.Enabled = True
Command3.Enabled = True
Data1.Recordset.MoveNext
End If
If Data1.Recordset.EOF Then
Data1.Recordset.MoveLast
Command2.Enabled = True
End If
Call ACT
End Sub
Private Sub Command3_Click() 'ATRAS
If Not Data1.Recordset.BOF Then
Command3.Enabled = True 'BTN ATRAS
Data1.Recordset.MovePrevious
End If
If Data1.Recordset.BOF Then
Data1.Recordset.MoveFirst
Command2.Enabled = True 'BTN AVANZAR
End If
Call ACT
End Sub
Private Sub Command4_Click()
Data1.Refresh
Unload Me
End Sub
Private Sub Command5_Click() 'ULTIMO
If Not Data1.Recordset.BOF Then
Command3.Enabled = True 'BTN ATRAS
Data1.Recordset.MoveLast
End If
If Data1.Recordset.EOF Then
Command2.Enabled = False 'BTN SIGUIENTE
Data1.Recordset.MoveLast
End If
Call ACT
End Sub
Private Sub Form_Load()
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "REPORTES"
Data1.Refresh
Call ACT
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub Text4_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub Text5_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub Text6_KeyPress(KeyAscii As Integer)
Call VAL_T(KeyAscii)
End Sub
Private Sub Text7_KeyPress(KeyAscii As Integer)
Call VAL_N(KeyAscii)
End Sub
Private Sub ACT()
If T7.Text = "-1" Then
Check1.Value = 1
End If
If T7.Text = "0" Then
Check1.Value = 0
End If
If T8.Text = "-1" Then
Check2.Value = 1
End If
If T8.Text = "0" Then
Check2.Value = 0 : End If
If T9.Text = "-1" Then
Check3.Value = 1
End If
If T9.Text = "0" Then
Check3.Value = 0
End If
End Sub
‘formulario de consulta de clientes COMERCIALIZACION
Private Sub Command1_Click()
INGRESO_CLIENTES.Show
End Sub
Private Sub Command3_Click() 'ACEPTAR ORDENAR
If OP1.Value = True Then
Data1.RecordSource = "SELECT * FROM CLIENTES ORDER BY CODIGO"
Data1.Refresh
End If
If OP2.Value = True Then
Data1.RecordSource = "SELECT * FROM CLIENTES ORDER BY NOMBRE"
Data1.Refresh
End If
If OP3.Value = True Then
Data1.RecordSource = "SELECT * FROM CLIENTES ORDER BY DIRECCION"
Data1.Refresh
End If
End Sub
Private Sub Command4_Click()
Data1.Refresh
COMERCIALIZACION.Hide
End Sub
Private Sub Form_Load()
MSF.ColWidth(0) = 1000
MSF.ColWidth(1) = 2500
MSF.ColWidth(2) = 2500
MSF.ColWidth(3) = 1500
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "CLIENTES"
Data1.Refresh
End Sub
‘formulario de consulta de proyectos realizados BASE_PROYECTOS
Private Sub CMDACEPTAR_Click()
If OP1.Value = True Then
Data1.RecordSource = "SELECT * FROM PRODUCCIONES ORDER BY NOMPROYECTO"
Data1.Refresh
End If
If OP2.Value = True Then
Data1.RecordSource = "SELECT * FROM PRODUCCIONES ORDER BY N_ORDEN"
Data1.Refresh
End If
If OP3.Value = True Then
Data1.RecordSource = "SELECT * FROM PRODUCCIONES ORDER BY UTILIDAD"
Data1.Refresh
End If
If OP4.Value = True Then
Data1.RecordSource = "SELECT * FROM PRODUCCIONES ORDER BY NOMCLIENTE"
Data1.Refresh
End If
If OP5.Value = True Then
Data1.RecordSource = "SELECT * FROM PRODUCCIONES ORDER BY COSTOU"
Data1.Refresh
End If
If OP6.Value = True Then
Data1.RecordSource = "SELECT * FROM PRODUCCIONES ORDER BY EGRESO"
Data1.Refresh
End If
If OP7.Value = True Then
Data1.RecordSource = "SELECT * FROM PRODUCCIONES ORDER BY PVP"
Data1.Refresh
End If
End Sub
Private Sub Command1_Click()
Data1.Refresh
Unload Me
End Sub
Private Sub Form_Load()
MSF1.ColWidth(1) = 2700
MSF1.ColWidth(1) = 2200
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "PRODUCCIONES"
Data1.Refresh
End Sub
‘fomulario de consulta de manufacturas BASE_MANUFACTURAS
Private Sub CMDACEPTAR_Click()
If Option1.Value = True Then
Data1.RecordSource = "SELECT * FROM PROYECTOS ORDER BY CODIGO"
Data1.Refresh
End If
If Option2.Value = True Then
Data1.RecordSource = "SELECT * FROM PROYECTOS ORDER BY PROYECTO"
Data1.Refresh
End If
End Sub
Private Sub CMDSALIR_Click()
Data1.Refresh
Unload Me
End Sub
Private Sub Command3_Click()
INGRESO_MANUFACTURAS.Show
End Sub
Private Sub Form_Load()
MSF.ColWidth(1) = 8000
Data1.DatabaseName = (App.Path & "IND.mdb")
Data1.RecordSource = "PROYECTOS"
Data1.Refresh
End Sub
Private Sub MSF_dblclick()
With BASE_MANUFACTURAS.MSF
FABRICACION.T1.Text = .TextMatrix(.Row, 0)
COSTOS.TCOD.Text = .TextMatrix(.Row, 0)
End With
End Sub
‘formulario informativo ACERCA DE
Option Explicit
' Opciones de seguridad de clave del Registro...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' Tipos ROOT de clave del Registro...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1 ' Cadena Unicode terminada en valor nulo
Const REG_DWORD = 4 ' Número de 32 bits
Const gREGKEYSYSINFOLOC = "SOFTWAREMicrosoftShared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWAREMicrosoftShared ToolsMSINFO"
Const gREGVALSYSINFO = "PATH"
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Sub cmdSysInfo_Click()
Call StartSysInfo
End Sub
Private Sub cmdOK_Click()
Unload Me
End Sub
Private Sub Form_Load()
Me.Caption = "Acerca de " & App.Title
lblVersion.Caption = "Versión " & App.Major & "." & App.Minor & "." & App.Revision
lblTitle.Caption = App.Title
End Sub
Public Sub StartSysInfo()
On Error GoTo SysInfoErr
Dim rc As Long
Dim SysInfoPath As String
' Intentar obtener ruta de acceso y nombre del programa de Info. del sistema a partir del Registro...
If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
' Intentar obtener sólo ruta del programa de Info. del sistema a partir del Registro...
ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
' Validar la existencia de versión conocida de 32 bits del archivo
If (Dir(SysInfoPath & "MSINFO32.EXE") <> "") Then
SysInfoPath = SysInfoPath & "MSINFO32.EXE"
' Error: no se puede encontrar el archivo...
Else
GoTo SysInfoErr
End If
' Error: no se puede encontrar la entrada del Registro...
Else
GoTo SysInfoErr
End If
Call Shell(SysInfoPath, vbNormalFocus)
Exit Sub
SysInfoErr:
MsgBox "La información del sistema no está disponible en este momento", vbOKOnly
End Sub
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
Dim I As Long ' Contador de bucle
Dim rc As Long ' Código de retorno
Dim hKey As Long ' Controlador de una clave de Registro abierta
Dim hDepth As Long '
Dim KeyValType As Long ' Tipo de datos de una clave de Registro
Dim tmpVal As String ' Almacenamiento temporal para un valor de clave de Registro
Dim KeyValSize As Long ' Tamaño de variable de clave de Registro
'------------------------------------------------------------
' Abrir clave de registro bajo KeyRoot {HKEY_LOCAL_MACHINE...}
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Abrir clave de Registro
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Error de controlador...
tmpVal = String$(1024, 0) ' Asignar espacio de variable
KeyValSize = 1024 ' Marcar tamaño de variable
'------------------------------------------------------------
' Obtener valor de clave de Registro...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
KeyValType, tmpVal, KeyValSize) ' Obtener o crear valor de clave
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Controlar errores
If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 agregar cadena terminada en valor nulo...
tmpVal = Left(tmpVal, KeyValSize - 1) ' Encontrado valor nulo, se va a quitar de la cadena
Else ' En WinNT las cadenas no terminan en valor nulo...
tmpVal = Left(tmpVal, KeyValSize) ' No se ha encontrado valor nulo, sólo se va a extraer la cadena
End If
'------------------------------------------------------------
' Determinar tipo de valor de clave para conversión...
'------------------------------------------------------------
Select Case KeyValType ' Buscar tipos de datos...
Case REG_SZ ' Tipo de datos String de clave de Registro
KeyVal = tmpVal ' Copiar valor de cadena
Case REG_DWORD ' Tipo de datos Double Word de clave del Registro
For I = Len(tmpVal) To 1 Step -1 ' Convertir cada bit
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, I, 1))) ' Generar valor carácter a carácter
Next
KeyVal = Format$("&h" + KeyVal) ' Convertir Double Word a cadena
End Select
GetKeyValue = True ' Se ha devuelto correctamente
rc = RegCloseKey(hKey) ' Cerrar clave de Registro
Exit Function ' Salir
GetKeyError: ' Borrar después de que se produzca un error...
KeyVal = "" ' Establecer valor a cadena vacía
GetKeyValue = False ' Fallo de retorno
rc = RegCloseKey(hKey) ' Cerrar clave de Registro
End Function
BIBLIOGRAFIA
Información relevante del Marco Teórico fue obtenida de la enciclopedia virtual Wikipedia. www.wikipedia.org
Apunto las direcciones electrónicas de los temas consultados:
http://es.wikipedia.org/wiki/Microempresa
http://es.wikipedia.org/wiki/idea
http://es.wikipedia.org/wiki/Producto
http://es.wikipedia.org/wiki/Mercado
http://es.wikipedia.org/wiki/Visual_Basic
http://es.wikipedia.org/wiki/Data_Access_
http://es.wikipedia.org/wiki/Estadisticas
http://es.wikipedia.org/wiki/Administraci%C3%B3n_de_ventas
http://es.wikipedia.org/wiki/Hazlo_t%C3%BA_mismo
http://es.wikipedia.org/wiki/Innovacion
http://es.wikipedia.org/wiki/Libertad
http://es.wikipedia.org/wiki/Perceptron
http://es.wikipedia.org/wiki/Costes
www.resursosvisualbasic.com.ar
www.monografias.com
www.mailxmail.com
Colección MSDN de Microsoft Corporation
La Biblia, versión Reina – Valera revisión de 1960