Este control nos resulta muy útil cuando queremos que los alumnos consulten determinados sitios, antes visitados por nosotros, y así evitamos navegaciones inútiles o peligrosas por sus contenidos.

If KeyAscii = 13 Then 'equivale a la tecla Enter

Command1_Click

End If

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)

Select Case Button.Key

Case "back" 'se identifica por la Key

On Error Resume Next

WebBrowser1.GoBack 'Retrocede

Case "forward"

On Error Resume Next

WebBrowser1.GoForward 'Adelanta

Case "home"

Text1.Text = "http://www.oocities.org/SiliconValley/Garage/6472"

Command1_Click

Case "refresh"

WebBrowser1.Refresh 'actualiza o refrezca

Case "stop"

WebBrowser1.Stop 'detiene la búsqueda

End Select

End Sub

Private Sub WebBrowser1_DownloadBegin()

StatusBar1.Panels(1).Text = "Cargando Página..."

End Sub

Private Sub WebBrowser1_DownloadComplete()

StatusBar1.Panels(1).Text = "Listo"

End Sub

If draw Then Line -(X, Y) ' si la variable draw esta a verdadera 'dibuja cada uno de los puntos.

End Sub

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

draw = False 'la variable draw a falsa detiene el dibujo

End Sub

 Los ejercicios Nº 17, 18 y 19 pueden bajarlos de Aquí.

Form2.Show

End Sub

Para desplegar la imagen del planeta usamos un control ImageList que tiene cargadas, en este caso solo dos imágenes: la Tierra y Júpiter.

La posición del registro depende del orden que le dieron a los planetas en los registros de la Base de datos.

Ustedes pueden agregar oros campos que desplieguen más información y labels indicativas de dichos campos.

Luego tenemos el Formulario evaluación que a través de la función InputBox le hace al alumno dos preguntas: Una sobre el nombre del planeta y otra sobre la cantidad de satélites que posee.

El proyecto final (incompleto) puede bajarse de Aquí.

End Sub

Private Sub Command3_Click() ' Botón Midi

MMControl1.Command = "Prev"

MMControl1.DeviceType = "Sequencer"' tipo de sonido

MMControl1.filename = App.Path & "\Thefinal.mid" 'camino

MMControl1.Command = "Open" 'lo abre

MMControl1.Command = "Play" lo ejecuta

End Sub

Debemos traer de Componentes el control Multimedia y poner todos sus botones a falsos e invisibles. Luego asociamos por código a cada control el archivo correspondiente, en este caso uno para el archivo Midi y otro para el Wave. Determinamos que tipo de dispositivo es y explicitamos su camino, lo abrimos y luego ejecutamos. No olvidarse el Open primero y luego el Play.

Private Sub Form_Unload(Cancel As Integer)

MMControl1.Command = "Close" 'lo cierra

MMControl2.Command = "Close" 'lo cierra

End Sub

Al descargar el formulario es fundamental cerrarlos para recuperar recursos del sistema.

El ejercicio completo puede bajarse de Aquí

Como vemos el código es muy sencillo. El ejercicio completo lo pueden bajar de Aquí.

nombreusuario = InputBox("Introduzca su Nombre")

contraseña = InputBox("Introduzca CONTRASEÑA")

If UCase(nombreusuario) = "LAURA" And LCase(contraseña) = "secreto" Then

MsgBox "¡BIENVENIDA LAURA! ¿Preparada para trabajar con tu PC?"

Image1.Visible = True

ElseIf UCase(nombreusuario) = "MIRTA" And LCase(contraseña) = "duende" Then

MsgBox "¿BIENVENIDA MIRTA AL SISTEMA! ¡A trabajar no te duermas!"

Image1.Visible = True

Else

MsgBox "ACCESO DENEGADO"

End If

Además de darnos el acceso con un saludo despliega una imagen en un control Image, en caso de no ser la contraseña o el nombre del usuario el indicado nos niega el acceso. Pueden bajar el ejercicio de Aquí.

Label1.Caption = "¡Incorrecto!"

End If

Call fin

End Sub

El procedimiento fin es el que testea si esta es la última pieza colocada y su código es:

Private Sub fin()

If Image9.Visible = False And Image10.Visible = False And Image11.Visible = False And Image12.Visible = False And Image13.Visible = False And Image14.Visible = False And Image15.Visible = False And Image16.Visible = False Then

Beep

Label2.Caption = ""

Label1.Caption = "¡Ganaste!"

End If

End Sub

El ejercicio completo puede bajarse de Aquí.

Aquí hay dos propiedades muy importantes, el caption del menú que será el título que aparezca en el menú y el name del menú, el caption puede estar vacío pero el name no, Y vamos anidando los submenús que queremos incorporar, como lo muestra la imagen, para desplegar un submenú hacemos click en next y en la flecha hacia la derecha para hacer una sangría que indica los subtemas del menú. Cada integrante del menú responde a un solo evento que es el Click. Para probarlo podemos agregar el siguiente código en el evento click de cada menú:

MnuFiambres_Click()

MsgBox "haz hecho click en la opción bandeja de Fiambres"

End Sub.

Esto no está incluído en el ejercicio, pero puede agregarle cualqier evento para testear el funcionamiento. En relación al código que hace visible u oculta un tipo de menú , agregamos un botón que aplica o ejecuta la opción de opción seleccionada con el siguiente código en el evento click del botón Aplicar:

Private Sub Command1_Click()

If Option1 Then ' mostrar menú de Entradas

mnuEntradas.Visible = True

mnuCalientes.Visible = False

mnuPostres.Visible = False

ElseIf Option2 Then ' mostrar menú Platos Calientes

mnuEntradas.Visible = False

mnuCalientes.Visible = True mnuPostres.Visible = False

Else

mnuEntradas.Visible = False

mnuCalientes.Visible = False

mnuPostres.Visible = True

End If

End Sub

este código relaciona mediante un condicional el menú que debe mostrarse y oculta los restantes. En el procedimiento Load del formulario incluimos el siguiente código, que oculta los menús:

Private Sub Form_Load()

mnuEntradas.Visible = False

mnuCalientes.Visible = False

mnuPostres.Visible = False

End Sub

El código del ejercicio puede bajarse de Aquí.

Private Sub Form_Click()

Dim msg As String, titulo As String

Dim color As String, colorArco As String

Beep

msg = "Introduzca un color."

titulo = " Cuestionario del Arco Iris."

color = InputBox(msg, titulo)

colorArco = LCase(color)

Select Case colorArco

Case "rojo", "naranja", "amarillo", "verde", "azul", "morado"

Print "Sí, el color "; color; " está en mí Arco Iris."

Case Else

Print "Lo siento, pero el color "; color; " no está en mí Arco Iris."

End Select

End Sub

El código del ejercicio completo puede bajarse de Aquí.

Para poder ejecutar un archivo AVI usamos el Control MCI, es un control multimedia que ya usamos para ejecutar archivos MIDI en otro ejercicio, y que debemos traer de componentes.

El código es el siguiente:

Private Sub video()

MMControl1.DeviceType = "AVIVideo"

MMControl1.filename = App.Path & "\ugachaka.Avi"

MMControl1.Command = "open"

MMControl1.hWndDisplay = Picture1.hWnd

MMControl1.Command = "play"

End Sub

Private Sub Command1_Click()

Call video

End Sub

Primero creamos un procedimiento llamado video y allí volcamos las indicaciones de la ejecución, pero ¡Atención! Usamos la propiedad Handle Window para manipular en que objeto se ejecuta el avi. Windows identifica así que queremos que se despliegue en la picture, a traves de la propiedad hWnd del control multimedia y de hWnd del control Picture.

El código completo sin el AVI puede bajarse de Aquí.

El código es el siguiente:

Private Sub Command1_Click()

End

End Sub

Private Sub Command2_Click()

MsgBox "Sufre el mismo mal que millones de Argentinos!!"

End Sub

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

Command2.Move CInt(Rnd * (Width - Command2.Width)), CInt(Rnd * (Height - Command2.Height))

End Sub

Con el Botón Si: salimos del programa y al querer hacer click en el botón: No, se mueve aleatoriamente a una nueva posición entre las medidas de ancho y alto del formulario.

El código del ejercicio pueden bajarlo de Aquí.

Option Explicit

Dim alta As Single

Dim dia As Integer

Dim baja As Single

Dim media As Single

Private Sub Command1_Click() ' mostrar el valor más alto de los textbox() en el text Alta

alta = Text1(0).Text

For dia = 1 To 6

If Text1(dia).Text > alta Then

alta = Text1(dia).Text

End If

Next dia

Text2.Text = alta

End Sub

Private Sub Command2_Click() 'calcular la más baja y lo muestra en el Text1(0).Text

For dia = 1 To 6

If Text1(dia).Text < baja Then

baja = Text1(dia).Text

End If

Next dia

Text3.Text = baja

End Sub

Private Sub

Command3_Click() 'calcula la media de los contenidos de text1()

Dim total As Single

Dim promedio As Single

total = 0

For dia = 0 To 6

total = total + Text1(dia)

Next dia

promedio = total / 7

Text4.Text = Format(promedio, "##.##") 'formato con dos decimales

End Sub

Private Sub Command4_Click()

For dia = 0 To 6

Text1(dia).Text = ""

Next dia

Text1(0).SetFocus

End Sub

Private Sub Command5_Click()

End

End Sub

Usando estructuras de repetición For Next, calculamos los valores de alta y baja, luego para la media sacamos por división el promedio.

El código completo del ejercicio podemos bajarlo de Aquí.

Tenemos dos controles para desplegar el texto: un Text1 y un RichTextBox1, y dos botones en cuyos eventos Click se desplegarán por código los archivos mencionados en los controles de texto. Primero debemos crear un archivo en el NotePad o en el Word y grabarlo como TXT y otro con variaciónes en el tipo, color y tamaño de la letra y grabarlo como rtf. Luego abrimos visual y en creamos un nuevo proyecto grabandolo en el mismo directorio y carpeta que tenemos los archivos: txt y rtf. El código de cada botón es el siguiente:

Option Explicit 'Esta expresión nos fuerza a declarar las variables.

Private Sub Command1_Click() 'Este boton es el que carga el 'archivo TXT

Dim pepe As String 'Declaramos una variable para identificar el 'archivo

Dim renglon As String 'Esta variable guardará el tamaño de 'cada renglón del archivo

renglon = Chr(13) & Chr(10) ' corta a otra línea

Text1.Text = "" Open App.Path & "\rtf.txt"

For Input As #1' Abre (Open) y da 'entrada (Input) el archivo 'ubicado en el mismo directorio y carpeta en que está la 'aplicación. App.path significa en la ruta actual de la'aplicación. 'Sino hay que indicar cual es el Path.

While Not EOF(1) ' esto realiza un bucle o sea repite la acción 'hasta que se llegue al final del archivo 1 (End of File)

Line Input #1, pepe$ ' le da entrada a la linea 1 del archivo Text1.Text = Text1.Text & pepe & renglon 'concatena con & el 'texto del archivo y el tamaño del reglón.

Wend 'repite las ordenes en tanto la condición es verdadera, en 'este caso hasta tanto no termine el texto del archivo.

Close #1 ' cierra el archivo al terminar de cargarlo.

End Sub

Private Sub Command2_Click()

RichTextBox1.LoadFile (App.Path & "\rtf.rtf") 'como podemos 'ver con el Control RichTextBox es más sencillo el manejo de 'archivos, con la sentencia LoadFile se carga el archivo 'indicando el camino para encontrarlo.

El código completo puede bajarse de Aquí.

Los procedimientos usados ya son conocidos: Dragear y soltar, uso de un Control PictureClip y de arrays de Imagenes para cargar las partes del rompecabezas.La imagen de la aplicación se parece a la siguiente:

Option Explicit

Private Sub Command1_Click()'el boton Salir cierra el programa

End

End Sub

Private Sub Command2_Click() 'este boton corrige si estan bien 'colocadas las imagenes. Debe escribirse todo el código 'seguido o cortarlo usando el under _

If Picture1.Picture = Image1(2).Picture And Picture2.Picture = Image1(1).Picture And Picture3.Picture = Image1(5).Picture And Picture4.Picture = Image1(0).Picture And Picture5.Picture = Image1(4) And Picture6.Picture = Image1(3).Picture Then

Picture1.Visible = False

Picture2.Visible = False

Picture3.Visible = False

Picture4.Visible = False

Picture5.Visible = False

Picture6.Visible =

False Image2.Visible = True 'carga otra imagen oculta que 'muestra un gato completo

Else 'sino es correcto vacía las imagenes para reiniciar el 'armado del rompecabezas.

Picture1.Picture = Nothing

Picture2.Picture = Nothing

Picture3.Picture = Nothing

Picture4.Picture = Nothing

Picture5.Picture = Nothing

Picture6.Picture = Nothing

End If

End Sub

Private Sub Form_Activate()' al cargarse el form y pasar a estar 'activo carga las celdas o partes en que dividimos la imagen con 'el PictureClip.

Image1(0).Picture = PictureClip1.GraphicCell(3) Image1(1).Picture = PictureClip1.GraphicCell(1) Image1(2).Picture = PictureClip1.GraphicCell(0) Image1(3).Picture = PictureClip1.GraphicCell(5) Image1(4).Picture = PictureClip1.GraphicCell(4) Image1(5).Picture = PictureClip1.GraphicCell(2)

End Sub

Private Sub Picture1_DragDrop(Source As Control, X As Single, Y As Single)

Picture1.Picture = Source

End Sub

Private Sub Picture2_DragDrop(Source As Control, X As Single, Y As Single)

'carga las imagenes de origen al soltarlas

Picture2.Picture = Source

End Sub Private Sub Picture3_DragDrop(Source As Control, X As Single, Y As Single)

Picture3.Picture = Source

End Sub

Private Sub

Picture4_DragDrop(Source As Control, X As Single, Y As Single)

Picture4.Picture = Source

End Sub

Private Sub Picture5_DragDrop(Source As Control, X As Single, Y As Single)

Picture5.Picture = Source

End Sub

Private Sub

Picture6_DragDrop(Source As Control, X As Single, Y As Single)

Picture6.Picture = Source

End Sub

El código completo puede bajarse de Aquí.

Usaremos en este ejercicio dos Scrollbar horizontales para modificar el valor de la propiedad QBColor que muestra 16 colores, con valores de 0 a 15, estos valores estarán asociados a la ubicación de la pestaña del Scroll y se mostrarán en dos cajas de texto.

Aquí también debemos prestar atención a la propiedad Value, Y a los procedimientos Change y Scroll, que testean cuando se modifica el valor de la barra horizontal. También debemos determinar los valores de las propiedades Min y Max en este caso, a 0 la primera y 15 la segunda y dejamos el LargeChange o sea el largo del cambio, a 1. El código es el siguiente:

Option Explicit

HScroll1_Change()

Text1.Text = HScroll1.Value

Text3.BackColor = QBColor(HScroll1.Value)

End Sub

Private Sub

HScroll1_Scroll()

Text1.Text = HScroll1.Value

Text3.BackColor = QBColor(HScroll1.Value)

End Sub

Private Sub

HScroll2_Change()

Text2.Text = HScroll2.Value

Text3.ForeColor = QBColor(HScroll2.Value)

End Sub

Private Sub

HScroll2_Scroll()

Text2.Text = HScroll2.Value

Text3.ForeColor = QBColor(HScroll2.Value)

End Sub

El código completo puede bajarse de Aquí.

Los controles que usamos son un Botón que activa el proceso y una picture que va cambiando su color a medida que el porcentaje aumenta.El código es el siguiente:

Private Sub Command1_Click()

Picture1.ForeColor = RGB(0, 0, 255) 'color azul

For i = 0 To 100 'un bucle que llama al procedimiento 'actualizaprogress

actualizaprogress Picture1, i

Call pausa 'procedimiento de espera

Next i

End Sub

Private Sub actualizaprogress(pb As Control, ByVal percent)

Dim num$ ' porcentaje

'el autoredraw de la picture debe estar a = true

pb.Cls

pb.ScaleWidth = 100

pb.DrawMode = 10

num$ = Format(percent, "##") + "%" 'calcula el porcentaje

pb.FontSize = 18

pb.CurrentX = 50 - pb.TextWidth(num$) / 2

pb.CurrentY = (pb.ScaleHeight - pb.TextHeight(num$)) / 2

pb.Print num$ 'imprime en la picture el porcentaje

pb.Line (0, 0)-(percent, pb.ScaleHeight), , BF 'dibuja el 'rectangulo

pb.Refresh 'actualiza la picture

End Sub

Private Sub pausa() 'procedimiento que detiene la aplicación 'un segundo

Dim controlar

Dim comenzar

comenzar = Timer

Do Until controlar >= comenzar + 0.2

controlar = Timer

DoEvents

Loop

End Sub

El código completo puede bajarse de Aquí.

Esta aplicación tiene además del Tab control un Data control que conecta con la base de datos que elijamos, y dentro del control tab tenemos controles Text y Labels para desplegar la información, como ya hemos hecho en otros ejercicios con Base de Datos. No hay código escrito, ya que las conecciones a la tabla estan hechas directamente a través de la ventana Propiedades. Tener en cuenta las propiedades: DataBasename, y los controles Text que desplieguen los campos elejidos.

La Aplicación puede bajarse de Aquí.

El código es el siguiente:

Option Explicit

Public pc, i As Integer

Private Sub Command1_Click()

Do

DoEvents

TransFX1.Effect = i

TransFX1.Start

Set TransFX1.PicBuffer = LoadPicture(App.Path & "\" &_ CStr(pc) & ".jpg")

pc = pc + 1: If pc > 3 Then pc = 1 i = i + 1: If i = 13 Then i = 1 Loop

End Sub

Private Sub

Command2_Click()

End

End Sub

Private Sub Form_Load()

pc = 1

i = 1

Set TransFX1.PicTarget = LoadPicture(App.Path & "\" &_ CStr(pc) & ".jpg")

Set TransFX1.PicBuffer = LoadPicture(App.Path & "\" &_ CStr(pc + 1) & ".jpg")

End Sub

Las propiedades principales son: PicTarget que es la primera imagen que carga y PicBuffer las siguientes, como minimo debemos tener 2 imagenes , pero podemos cargar varias más. Y el método Start que lo inicia, podríamos usar un timer pero en este caso es un bucle el que repite la operación pasando entre los 15 efectos posibles que permite el control.

Por cualquier duda incluyo el archivo de Ayuda del creador del activeX. Los archivos con el control pueden bajarse de Aquí.

Los insectos se mueven en forma aleatoria mediante un random y los ojos de la ranita tienen una animación, donde se abren y cierran, además de los controles Images, tenemos dos labels transparentes, una que muestra el puntaje y otra que resetea la aplicación. Y el sonido está activado usando la API sndPlaySound de windows.

El código es el siguiente:

Option Explicit

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Const SND_ASYNC = &H1 ' reproducción asíncrona

Const SND_NODEFAULT = &H2 ' silencio no predeterminado, si no se encuentra sonido

Private ret As Integer

Private contar As Integer

Private a As Integer

Private b As Integer

Private tiempo As Integer

Private Sub pausa()

Dim comenzar

Dim controlar

comenzar = Timer

Do Until controlar >= comenzar + 1

controlar = Timer

DoEvents

Loop

End Sub

Private Sub Form_Load()

Randomize b = 0

End Sub

Private Sub Image6_Click(Index As Integer) Image6(Index).Visible = False

b = b + 10

If Image6(Index).Left >= 2600 Then

Image7.Visible = True

ret = sndPlaySound(App.Path & "\Frogs.wav", SND_ASYNC Or SND_NODEFAULT)

ElseIf Image6(Index).Left <= 2600 Then

Image8.Visible = True

ret = sndPlaySound(App.Path & "\Frogs.wav", SND_ASYNC Or SND_NODEFAULT)

End If

Call pausa

Image7.Visible = False

Image8.Visible = False

Label1.Caption = "Puntaje =" & b

Call ganar

Call perder

End Sub

Private Sub Label2_Click()

Unload Me

Me.Show

End Sub

Private Sub Timer1_Timer()

contar = contar + 1

If contar = 1 Then

Image1.Picture = Image3.Picture

Image2.Picture = Image3.Picture

ElseIf contar = 2 Then

Image1.Picture = Image4.Picture

Image2.Picture = Image4.Picture

ElseIf contar = 3 Then

Image1.Picture = Image3.Picture

Image2.Picture = Image3.Picture

ElseIf contar = 4 Then

Image1.Picture = Image5.Picture

Image2.Picture = Image5.Picture

contar = 0

End If

End Sub

Private Sub

Timer2_Timer()

Dim x As Integer, y As Integer

For a = 0 To 9

Image6(a).Move CInt(Rnd * (Width - Image6(a).Width)), CInt(Rnd * (Height - 1600))

Next a

End Sub

Private Sub ganar()

If b = 100 Then

Label1.Caption = "¡¡GANASTE!!"

ret = sndPlaySound(App.Path & "\Fanfare.wav", SND_ASYNC Or SND_NODEFAULT)

End If

End Sub

Private Sub perder()

If tiempo = 60 Then

Timer1.Enabled = False

Timer2.Enabled = False

Timer3.Enabled = False

Label1.Caption = "¡¡Perdiste!!"

ret = sndPlaySound(App.Path & "\desapa.wav", SND_ASYNC Or SND_NODEFAULT)

End If

End Sub

Private Sub

Timer3_Timer() tiempo = tiempo + 1

Call perder

End Sub

Como vemos creamos tres procedimientos personalizados, ganar, perder y pausa. El ejercicio completo puede bajarse de Aquí.

Option Explicit

Const SRCAND = &H8800C6

Const SRCINVERT = &H660046

Private Sub Form_Load()

PictureClip1.Rows = 3

PictureClip1.Cols = 3

PictureClip2.Rows = 3

PictureClip2.Cols = 3

End Sub

Private Sub Timer1_Timer()

Form1.Refresh

Dim x As Single, y As Single

Static imagenactual As Integer

Static imagenactual1 As Integer

Static xactual As Integer

Static xactual1 As Integer

If imagenactual > 5 Then

imagenactual = 3

If imagenactual < 2 Then

imagenactual = 2

If imagenactual1 > 2 Then

imagenactual1 = 0

If imagenactual1 < 0 Then

imagenactual1 = 0

If xactual > 1000 Then

xactual = 10

If xactual < 0 Then

xactual = 10

If xactual1 > 1000 Then

xactual = 1000

If xactual1 <= 0 Then

xactual1 = 1000

Form1.PaintPicture PictureClip2.GraphicCell(imagenactual), xactual, 120, , , , , , , SRCAND

Form1.PaintPicture PictureClip1.GraphicCell(imagenactual), xactual, 120, , , , , , , SRCINVERT

Form1.PaintPicture PictureClip2.GraphicCell(imagenactual1), xactual1, 250, , , , , , , SRCAND

Form1.PaintPicture PictureClip1.GraphicCell(imagenactual1), xactual1, 250, , , , , , , SRCINVERT

imagenactual = imagenactual + 1

imagenactual1 = imagenactual1 + 1

xactual = xactual + 100

xactual1 = xactual1 - 100

End Sub

El ejercicio completo puede bajarse de Aquí.

El código es el siguiente:

Option Explicit

Dim numero(1 To 20) As Integer

Dim I As Integer

Dim a As Integer

Dim J As Integer

Dim idxtemp As Integer

Dim s As Integer

Private Sub azar()

Static temparray(1 To 20) As Integer

Randomize

For I = 1 To 20 temparray(I) = I

Next I

Top = 20

For I = 1 To 20

idxtemp = Int(Top * Rnd + 1)

numero(I) = temparray(idxtemp)

For J = idxtemp To Top - 1

temparray(J) = temparray(J + 1)

Next J

Top = Top - 1

'Print numero(I)

Next I

End Sub

Private Sub Command1_Click()

If I > 1 Then

Label1.Caption = numero(I - 1)

Call mostrar

I = I - 1

Else

Call azar

End If

End Sub

Private Sub

Command3_Click()

End

End Sub

Private Sub Command4_Click()

Text1.Text = ""

Text1.SetFocus

End Sub

Private Sub

Form_Activate()

Text1.SetFocus

End Sub

Private Sub

Form_Load()

Randomize

Call azar

Call Command1_Click

End Sub

Private Sub mostrar()

Select Case Label1

Case 1

Command2.Picture = Image1(0).Picture

Case 2

Command2.Picture = Image1(1).Picture

Case 3

Command2.Picture = Image1(2).Picture

Case 4

Command2.Picture = Image1(3).Picture

Case 5

Command2.Picture = Image1(4).Picture

Case 6

Command2.Picture = Image1(5).Picture

Case 7

Command2.Picture = Image1(6).Picture

Case 8

Command2.Picture = Image1(7).Picture

Case 9

Command2.Picture = Image1(8).Picture

Case 10

Command2.Picture = Image1(9).Picture

Case 11

Command2.Picture = Image1(10).Picture

Case 12

Command2.Picture = Image1(11).Picture

Case 13

Command2.Picture = Image1(12).Picture

Case 14

Command2.Picture = Image1(13).Picture

Case 15

Command2.Picture = Image1(14).Picture

Case 16

Command2.Picture = Image1(15).Picture

Case 17

Command2.Picture = Image1(16).Picture

Case 18

Command2.Picture = Image1(17).Picture

Case 19

Command2.Picture = Image1(18).Picture

Case 20

Command2.Picture = Image1(19).Picture

End Select

End Sub

Private Sub

Text1_Change()

Call corregir

End Sub

Private Sub corregir()

Static puntos As Integer

Select Case Label1

Case 1

If UCase(Text1.Text) = "CARAMBOLA" Then

puntos = puntos + 1

Case 2

If UCase(Text1.Text) = "APRESADO" Then

puntos = puntos + 1

Case 3

If UCase(Text1.Text) = "APRENDER" Then

puntos = puntos + 1

Case 4

If UCase(Text1.Text) = "CAJÓN" Then

puntos = puntos + 1

Case 5

If UCase(Text1.Text) = "CAMPAÑA" Then

puntos = puntos + 1

Case 6

If UCase(Text1.Text) = "CANOSO" Then

puntos = puntos + 1

Case 7

If UCase(Text1.Text) = "CARACÚ" Then

puntos = puntos + 1

Case 8

If UCase(Text1.Text) = "CASINO" Then

puntos = puntos + 1

Case 9

If UCase(Text1.Text) = "CORAZONADA" Then

puntos = puntos + 1

Case 10

If UCase(Text1.Text) = "CUCHARITA" Then

puntos = puntos + 1

Case 11

If UCase(Text1.Text) = "DEMONIO" Then

puntos = puntos + 1

Case 12

If UCase(Text1.Text) = "DEPORTE" Then

puntos = puntos + 1

Case 13

If UCase(Text1.Text) = "DIARIO" Then

puntos = puntos + 1

Case 14

If UCase(Text1.Text) = "DUENDE" Then

puntos = puntos + 1

Case 15

If UCase(Text1.Text) = "AUSTRALIA" Then

puntos = puntos + 1

Case 16

If UCase(Text1.Text) = "FLORENCIA" Then

puntos = puntos + 1

Case 17

If UCase(Text1.Text) = "INGENIO" Then

puntos = puntos + 1

Case 18

If UCase(Text1.Text) = "REINO" Then

puntos = puntos + 1

Case 19

If UCase(Text1.Text) = "VATICANO" Then

puntos = puntos + 1

Case 20

If UCase(Text1.Text) = "SOLDADO" Then

puntos = puntos + 1

End Select

Label2.Caption = "PUNTOS: " & puntos If puntos >= 20 Then

Label2.Caption = "¡Ganaste!"

End If

End Sub

El ejercicio completo puede bajarse de Aquí.

Option Explicit

Dim a As Integer

Private Sub Command1_Click()

End

End Sub

Private Sub Timer1_Timer()

a = a + 1

If a >= 7 Then

a = 0

Picture1.Picture = Image1(a).Picture

End Sub

La aplicación completa puede bajarse de Aquí.

Option Explicit

Private Sub HScroll1_Change()

Label3.Caption = Format$(HScroll1.Value)

Label4.Caption = Chr$(HScroll1.Value)

End Sub

El Los controles son: una label que indica que debemos contesar la pregunta y luego hacer click en la imagen del doctor. Una label que despliega las preguntas que hace el doctor y una caja de texto enriquecido osea un RichTextBox donde debemos ingresar nosotros las respuestas. Ademas tenemos oculto un control list que carga la lista de palabras claves. El código es el siguiente:

Option Explicit

Dim contar As Integer

Dim palabra As Integer

Dim frase As String

Dim pepe As String

Dim a As Integer Private

Sub pausa()

Dim comenzar

Dim chequeo

comenzar = Timer

Do Until chequeo >= comenzar + 1

chequeo = Timer

DoEvents

Loop

End Sub

Private Sub Command1_Click()

End

End Sub

Private Sub Form_Activate()

RichTextBox1.SetFocus

End Sub

Private Sub Form_Load()

Randomize

Call frasedoctor

List1.AddItem "tu"

List1.AddItem "te"

List1.AddItem "pienso"

List1.AddItem "bien"

List1.AddItem "regular"

List1.AddItem "¿que"

List1.AddItem "quiero"

List1.AddItem "deprimido"

List1.AddItem "sin"

List1.AddItem "dificil"

List1.AddItem "esperar"

List1.AddItem "necesito"

List1.AddItem "¿por que?"

List1.AddItem "se"

List1.AddItem "adios"

List1.AddItem "odio"

List1.AddItem "amor"

List1.AddItem "asesino"

List1.AddItem "matar"

List1.AddItem "grosero"

List1.AddItem "no puedo"

List1.AddItem "fracaso"

List1.AddItem "nunca"

List1.AddItem "infeliz"

'Text1.Text = List1.List(3)

End Sub Private

Sub frasedoctor()

frase = Int(Rnd * 8)

Select Case frase

Case 0

Label1.Caption = "¿Cómo está Ud.?"

Case 1

Label1.Caption = "¿Cuál es su estado de ánimo?"

Case 2

Label1.Caption = "¿Tuvo Ud. una infancia feliz?"

Case 3

Label1.Caption = "¿Es feliz con el medio que lo rodea?"

Case 4

Label1.Caption = "¿Tiene problemas para relacionarse?"

Case 5

Label1.Caption = "¿Odia Ud. a su padre?"

Case 6

Label1.Caption = "¿Cree que no lo comprenden?"

Case 7

Label1.Caption = "Yo no estoy seguro de entenderlo"

End Select

End Sub

Private Sub respuestadoctor()

palabra = 0

If palabra >= 0 Then

For a = 0 To 24

pepe = List1.List(a) palabra = RichTextBox1.Find(pepe, palabra + 1, , 2) pepe = RichTextBox1.SelText

Next a

End If

'Print pepe

RichTextBox1.Text = ""

Call respuestapaciente

End Sub

Private Sub

Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Call respuestadoctor

End Sub

Private Sub

RichTextBox1_Click()

RichTextBox1.Text = ""

End Sub

Private Sub respuestapaciente()

Select Case pepe

Case "tu"

Label1.Caption = "No hablemos de mi."

Case "te"

Label1.Caption = "Dejemos de hablar de mi."

Case "pienso"

Label1.Caption = "¿Por qué piensa eso?"

Case "bien"

Label1.Caption = " Me alegra, cuénteme sobre Ud."

Case "regular"

Label1.Caption = "Entiendo, Cuenteme sobre Ud."

Case "¿que"

Label1.Caption = "¿Por qué pregunta Ud.?"

Case "quiero"

Label1.Caption = "¿Por qué quiere usted eso?"

Case "deprimido"

Label1.Caption = "¿Qué lo deprime?"

Case "sin"

Label1.Caption = "Entiendo. ¿Cree que lo puede remediar?"

Case "¿por que"

Label1.Caption = "Recuerde, la terapia es buena para Ud."

Case "dificil"

Label1.Caption = "No se preocupe, ya cambiarán las cosas."

Case "esperar"

Label1.Caption = "Tenga algo de paciencia."

Case "necesito"

Label1.Caption = "Todos necesitamos cosas."

Case "se"

Label1.Caption = "¿Como sabe Ud. eso?"

Case "odio"

Label1.Caption = "El odio nunca conduce a nada bueno"

Case "amor"

Label1.Caption = "Es importante amar"

Case "asesino"

Label1.Caption = "No me gusta la gente que mata"

Case "matar"

Label1.Caption = "No esta bien matar"

Case "grosero"

Label1.Caption = "¡No esta bien que me hable así!"

Case "no puedo"

Label1.Caption = "No sea negativo, sea positivo"

Case "fracaso"

Label1.Caption = " Debe luchar por el exito"

Case "nunca"

Label1.Caption = "No sea negativo, sea positivo"

Case "infeliz"

Label1.Caption = "¿Por que es infeliz?"

Case "adios"

Label1.Caption = "Le enviaré la factura. Gracias."

RichTextBox1.Locked = True

Beep

Call pausa

End Case

Else

Call frasedoctor

End Select

End Sub

El código completo puede bajarse de AQUÍ.

Al cumplirse la condición despliega un MsgBox con el mensaje que ingresamos, y mientras se mantiene minimizada la aplicación para que podamos seguir trabjando con otros programas.

El código es :

Option Explicit

Dim recordar As String

Dim horaActual As Date

Private Sub Command1_Click()

Timer1.Enabled = True

Me.WindowState = 1

End Sub

Private Sub Command2_Click()

End

End Sub

Private Sub

Form_Activate()

Text1.SetFocus

End Sub

Private Sub

Timer1_Timer()

horaActual = Format(Time, "hh:mm")

If horaActual >= Text1.Text Then

Beep

recordar = MsgBox(Text2.Text, vbInformation, "Alarma")

Timer1.Enabled = False

Form1.WindowState = 0

End If

End Sub

El código completo puede bajarse de AQUÍ.

El código del ejercicio es:

Option Explicit

Private Sub Command1_Click()

Dim x As Integer

Dim y As Integer

Dim color As Integer

Dim i As Integer

For i = 1 To 20

x = Int(ScaleWidth * Rnd)

y = Int(ScaleHeight * Rnd)

color = Int(16 * Rnd)

PSet (x, y), QBColor(color)

Next

End Sub

Private Sub

Command2_Click()

Cls

End Sub

Private Sub Command3_Click()

Form1.PrintForm

End Sub

Private Sub Form_Load()

Randomize

End Sub

Como vemos usamos la función randomize para ubicar los puntos en forma aleatoria en el formulario y un bucle For/Next que dibuja 20 puntos por cada click que hacemos en el botón: Puntos, el otro botón borra con Cls lo dibujo o sea limpia el form. El método Pset (Point Set) dibuja los puntos combinada con QBColor que le asigna un color. El formato de los puntos es Dot.

El ejercicio completo pueden bajarlo de AQUÍ.

La declaración general de variables y el código para cada botón es:

Option Explicit

Dim x, y, r As Integer

Dim x1 As Integer, y1 As Integer

Dim x2 As Integer, y2 As Integer

Dim color As Integer

Dim ccolor As Integer

Private Sub Command1_Click()'Botón Rectas

'puntos extremos y color aleatorio

x1 = Fix(Me.ScaleWidth * Rnd)

y1 = Fix(Me.ScaleHeight * Rnd)

x2 = Fix(Me.ScaleWidth * Rnd)

y2 = Fix(Me.ScaleHeight * Rnd)

color = Fix(16 * Rnd) Randomize

'trazar una recta

Line (x1, y1)-(x2, y2), QBColor(color) 'los dos primeros valores 'establecen un punto extremo y los otros dos el otro punto extemo, 'entre ambos se dibuja la recta.

End Sub

Private Sub Command2_Click() 'Botón Imprimir por Impresora.

Me.PrintForm

End Sub

Private Sub Command3_Click() 'Botón Rectángulo

x1 = Fix(Me.ScaleWidth * Rnd)

y1 = Fix(Me.ScaleHeight * Rnd)

x2 = Fix(Me.ScaleWidth * Rnd)

y2 = Fix(Me.ScaleHeight * Rnd)

color = Fix(16 * Rnd)'elige al azar un color

Randomize FillStyle = 1

'dibuja un cuadro(B)

Line (x1, y1)-(x2, y2), QBColor(color), B

End Sub

Private Sub Command4_Click() 'Botón Rectángulo relleno

x1 = Fix(Me.ScaleWidth * Rnd)

y1 = Fix(Me.ScaleHeight * Rnd)

x2 = Fix(Me.ScaleWidth * Rnd)

y2 = Fix(Me.ScaleHeight * Rnd)

color = Fix(16 * Rnd)Randomize

'dibuja un cuadro(B)

Line (x1, y1)-(x2, y2), QBColor(color), BF

End Sub

Private Sub Command5_Click() 'Borra o Limpia Formulario

Cls

End Sub

Private Sub Command6_Click() 'Botón Círculo relleno

'coordenadas del Centro, Radio y Color, aleatorias

x = Fix(Me.ScaleWidth * Rnd)

y = Fix(Me.ScaleHeight * Rnd)

r = Fix(1000 * Rnd)

color = Fix(16 * Rnd)

Randomize

FillStyle = 1'rellena el círculo

'dibuja una circunferencia

Circle (x, y), r, QBColor(color)

End Sub

Private Sub Command7_Click() 'Botón Círculo

x = Fix(Me.ScaleWidth * Rnd)

y = Fix(Me.ScaleHeight * Rnd)

r = Fix(1000 * Rnd)

color = Fix(16 * Rnd)

ccolor = Fix(16 * Rnd)

Randomize

FillStyle = 0

FillColor = QBColor(ccolor)

'dibuja una circunferencia

Circle (x, y), r, QBColor(color)

End Sub

Private Sub Command8_Click() 'Botón Puntos

Randomize

x = Fix(Me.ScaleWidth * Rnd)

y = Fix(Me.ScaleHeight * Rnd)

color = Fix(16 * Rnd)

PSet (x, y), QBColor(color) 'Dibuja Puntos

End Sub

Para dibujar las Rectas debemos indicarle dos valores de: x, e y para uno de los puntos extremos y x1, Y1 para el otro luego con el método Line dibuja una recta que une ambos puntos. Cuando dibuja un rectángulo. También necesita estos valores pero para dibujar dos líneas rectas que luego repite en espejo para formar una Box o Caja, y así aparece el cuadrado o rectángulo. Cuandoq uqeremos que ese rectángulo este relleno la indicación será BF o sea Box Fill, o Caja rellena. Para esto la propiedad FillStyle debe estar a True. Y con el Círculo necesitamos un valor para x, y otro para y para establecer un punto que será el centro de la circunferencia y un valor para el radio. Para determinar los colores lo hacemos usando un Randome y la función QBColor. El ejercicio completo puede bajarse de Aquí.