Buscaminas hecho en VB6
Fecha: 08/Jun/2005 (08/Jun/05)
|
Epilogo
En mi instituto Paul Müller, me encontré con unos amigos de un ciclo anterior al mío, 3er ciclo, y me comentario que el profesor de VB del había dejado como trabajo final que hicieran un Buscaminas y yo me quede lelo. @_@
Este profesor esta acostumbrado a dejar juegos en ese ciclo como trabajo final. A mi salón nos dejo un Ajedrez que por cierto lo deje a medias :p, es que el tiempo se me acabo y ya ps.
A los hechos
A todo esto, como me encanta programar y más si se trata de estos jueguitos, ps me decidí hacerlo yo también y he de confesar que me rompía la cabeza en ese entonces pero como todo esfuerzo tiene sus frutos, lo conseguí. Pero no tiene todas las opciones del Buscaminas de Windows. Es que, como no era un trabajo para presentar, me conforme con que funcionará lo principal e indispensable en el juego.
Pero ya basta de tanto bla bla bla y vamos con el código:
' El codigo no esta comentado pero ahí esta ' para que le den un ojo a quien le interese. ' ' Usen Interrupciones(F9) o el modo Depuración(Shift+F8). ' ' Tiene una falla mi algoritmo para este juego. ' Al primer clic en un boton nunca deberia de aparecer una mina. Option Explicit Const ColorLinea = &H808080 Dim L As Byte, R As Byte Dim i As Integer, n As Integer 'Variables para recorrido Dim T As Integer 'TotalBotones Dim H As Integer 'BotonesOcultos Dim Working As Boolean 'Proceso Private Sub cmd_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) cmdNuevo.Picture = ImgCarita(1).Picture End Sub Private Sub cmd_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If Index Mod (a + 2) = 0 Or _ Index Mod (a + 2) = (a + 2) - 1 Or _ cmd(Index).Enabled = False Or _ cmd(Index).Visible = False Then Exit Sub If Button = vbLeftButton Then If cmd(Index).Picture = ImgMarca.Picture Then cmdNuevo.Picture = ImgCarita(0).Picture Exit Sub End If Select Case cmd(Index).Tag Case "M" With cmd(Index) 'Cuadro rojo en la mina seleccionada picFondo.Line (.Left, .Top)-(.Left + .Width, .Top + .Height), vbRed, BF End With 'Se recorren todos los botones For i = 0 To cmd.UBound If cmd(i).Tag = "M" Then If cmd(i).Picture <> ImgMarca.Picture Then cmd(i).Visible = False End If Else If cmd(i).Picture = ImgMarca.Picture Then Dim n% n = ImgNoMina.Count Load ImgNoMina(n) With ImgNoMina(n) .Left = cmd(i).Left + 30 .Top = cmd(i).Top + 30 .Visible = True End With cmd(i).Visible = False Else cmd(i).Enabled = False End If End If Next cmdNuevo.Picture = ImgCarita(2).Picture Timer1.Enabled = False Exit Sub Case Empty ' "" cmd(Index).Visible = False On Error Resume Next Call cmd_MouseUp(Index - (a + 2) - 1, vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Index - (a + 2)), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Index - (a + 2) + 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Index - 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Index + 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Index + (a + 2) - 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Index + (a + 2)), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Index + (a + 2) + 1), vbLeftButton, 0, 0, 0) On Error GoTo 0 H = H + 1 cmdNuevo.Picture = ImgCarita(0).Picture 'Si el resto son las dos columnas ocultas 'y solo las minas entonces "Ganaste". If T + 1 - H = (b * 2) + Minas Then Timer1.Enabled = False cmdNuevo.Picture = ImgCarita(3).Picture For i = 0 To cmd.UBound If cmd(i).Tag = "M" Then cmd(i).Enabled = False End If Next DoEvents If Val(lblTiempo.Caption) < Seg Then frmNuevoRecord.Show 1 End If Else cmdNuevo.Picture = ImgCarita(0).Picture If Val(lblTiempo.Caption) = 0 Then lblTiempo.Caption = "001" Timer1.Enabled = True End If End If Case Else With picFondo Select Case Val(cmd(Index).Tag) Case 1: .ForeColor = vbBlue Case 2: .ForeColor = &H8000& Case 3: .ForeColor = vbRed Case 4: .ForeColor = vbBlack Case Else: .ForeColor = vbCyan End Select .CurrentX = cmd(Index).Left + 60 .CurrentY = cmd(Index).Top + 30 End With picFondo.Print cmd(Index).Tag cmd(Index).Visible = False H = H + 1 'Si el resto son las dos columnas ocultas 'y solo las minas entonces "Ganaste". If T + 1 - H = (b * 2) + Minas Then Timer1.Enabled = False cmdNuevo.Picture = ImgCarita(3).Picture For i = 0 To cmd.UBound If cmd(i).Tag = "M" Then cmd(i).Enabled = False End If Next DoEvents If Val(lblTiempo.Caption) < Seg Then frmNuevoRecord.Show 1 End If Else cmdNuevo.Picture = ImgCarita(0).Picture If Val(lblTiempo.Caption) = 0 Then lblTiempo.Caption = "001" Timer1.Enabled = True End If End If End Select ElseIf Button = vbRightButton Then If cmd(Index).Picture = ImgMarca.Picture Then cmd(Index).Picture = LoadPicture("") cmd(Index).DisabledPicture = LoadPicture("") lblMinas.Caption = Format$(Val(lblMinas.Caption) + 1, IIf(Val(lblMinas.Caption) + 1 < 0, "00", "000")) Else cmd(Index).Picture = ImgMarca.Picture cmd(Index).DisabledPicture = ImgMarca.Picture lblMinas.Caption = Format$(Val(lblMinas.Caption) - 1, IIf(Val(lblMinas.Caption) - 1 < 0, "00", "000")) End If cmdNuevo.Picture = ImgCarita(0).Picture End If End Sub Private Sub cmdNuevo_Click() If Working Then Exit Sub Call CargarTodo End Sub Private Sub Form_Load() INI = App.Path & "\buscaminas.ini" Tipo = "Principiante" If Len(Dir(INI, vbArchive)) = 0 Then Call Reset DoEvents End If Call Recupera a = 9: b = 9: Minas = 10 Call CargarTodo End Sub Sub CargarTodo() Working = True a = a + 2 T = (a * b) - 1 H = 0 Timer1.Enabled = False lblTiempo.Caption = "000" lblMinas.Caption = Format$(Minas, "000") 'Destruimos todas las minas For i = ImgMina.UBound To 1 Step -1 Unload ImgMina(i) Next ImgMina(0).Visible = False 'Destruimos todas las NoMinas For i = ImgNoMina.UBound To 1 Step -1 Unload ImgNoMina(i) Next ImgNoMina(0).Visible = False 'Destruimos todos los botones For i = cmd.UBound To 1 Step -1 Unload cmd(i) Next cmd(0).Visible = False cmd(0).Enabled = True cmd(0).BackColor = &HC0C0C0 cmd(0).Picture = LoadPicture("") cmd(0).Tag = "" 'Borro la Anterior Cuadricula picFondo.Cls 'Tamaño del Fondo picFondo.Width = cmd(0).Width * (a - 2) + 60 picFondo.Height = cmd(0).Height * b + 60 'Tamaño del Panel picPanel.Width = picFondo.Width 'Posiciones en el Panel lblMinas.Left = 120 cmdNuevo.Left = (picPanel.ScaleWidth - cmdNuevo.Width) / 2 lblTiempo.Left = picPanel.ScaleWidth - lblTiempo.Width - 120 'Tamaño del Form Me.Width = picFondo.Width + (picFondo.Left * 2) + 90 Me.Height = picFondo.Top + picFondo.Height + picFondo.Left + 780 'Dibujo la Nueva Cuadricula For i = 1 To a - 3 picFondo.Line (cmd(0).Width * i, 0)-(cmd(0).Width * i, picFondo.ScaleHeight), ColorLinea, B Next For i = 1 To b - 1 picFondo.Line (0, cmd(0).Height * i)-(picFondo.ScaleWidth, cmd(0).Height * i), ColorLinea, B Next DoEvents 'Posicionamos y mostramos los nuevos botones cmd(0).Move -cmd(0).Width, 0 cmd(0).Visible = True For i = 1 To T Load cmd(i) With cmd(i) .Top = cmd(i - 1).Top .Left = cmd(i - 1).Left + cmd(i - 1).Width If i Mod a = 0 Then .Top = cmd(i - 1).Top + cmd(i - 1).Height .Left = cmd(0).Left End If .Visible = True End With Next 'Minas y Números Randomize Second(Now) For i = 1 To Minas 'Ubicación aleatoria para la mina n = CInt(Rnd * T) Do While cmd(n).Tag = "M" Or n Mod a = 0 Or n Mod a = a - 1 Or n = T n = CInt(Rnd * T) Loop cmd(n).Tag = "M" 'cmd(n).BackColor = vbRed Dim k As Integer k = ImgMina.UBound With ImgMina(k) .Left = cmd(n).Left + 30 .Top = cmd(n).Top + 30 .Visible = True End With If i <> Minas Then Load ImgMina(k + 1) On Error Resume Next If cmd(n - a - 1).Tag <> "M" Then cmd(n - a - 1).Tag = CStr(Val(cmd(n - a - 1).Tag) + 1) If cmd(n - a).Tag <> "M" Then cmd(n - a).Tag = CStr(Val(cmd(n - a).Tag) + 1) If cmd(n - a + 1).Tag <> "M" Then cmd(n - a + 1).Tag = CStr(Val(cmd(n - a + 1).Tag) + 1) If cmd(n - 1).Tag <> "M" Then cmd(n - 1).Tag = CStr(Val(cmd(n - 1).Tag) + 1) If cmd(n + 1).Tag <> "M" Then cmd(n + 1).Tag = CStr(Val(cmd(n + 1).Tag) + 1) If cmd(n + a - 1).Tag <> "M" Then cmd(n + a - 1).Tag = CStr(Val(cmd(n + a - 1).Tag) + 1) If cmd(n + a).Tag <> "M" Then cmd(n + a).Tag = CStr(Val(cmd(n + a).Tag) + 1) If cmd(n + a + 1).Tag <> "M" Then cmd(n + a + 1).Tag = CStr(Val(cmd(n + a + 1).Tag) + 1) On Error GoTo 0 Next cmdNuevo.Picture = ImgCarita(0).Picture a = a - 2 Working = False End Sub Private Sub Form_Unload(Cancel As Integer) Call EnumWindows(AddressOf CerrarAyudaProc, ByVal 0&) End End Sub Private Sub mnuAcercaDe_Click() Call ShellAbout(Me.hWnd, Me.Caption, _ "Desarrollado en Visual Basic 6 por:" & Chr(13) & _ "Renzo Galo Castro Jurado (+Otaku RzO+)", Me.Icon) End Sub Private Sub mnuColor_Click() mnuColor.Checked = Not (mnuColor.Checked) End Sub Private Sub mnuContenido_Click() 'Ruta de la ayuda en XP '"X:\WINDOWS\Help\winmine.chm" Dim Res As Long Res = AbrirArchivo(Me.hWnd, DirectorioWindows & "\Help\winmine.chm") If Res = 2 Then MsgBox "Hubo un error.", vbCritical, "Archivo no encontrado" ElseIf Res = 42 Then 'La ayuda abrio correctamente End If End Sub Private Sub mnuMarcas_Click() mnuMarcas.Checked = Not (mnuMarcas.Checked) End Sub Private Sub mnuMejoresTiempos_Click() frmMejoresTiempos.Show 1 End Sub Private Sub mnuModo_Click(Index As Integer) For i = 0 To mnuModo.UBound mnuModo(i).Checked = False Next mnuModo(Index).Checked = True Select Case Index Case 0: a = 9: b = 9: Minas = 10: Tipo = "Principiante" Case 1: a = 16: b = 16: Minas = 40: Tipo = "Intermedio" Case 2: a = 30: b = 16: Minas = 99: Tipo = "Experto" Case 3: frmPersonalizar.Show 1: Tipo = "Personalizado" End Select Call Recupera Call CargarTodo End Sub Private Sub mnuNuevo_Click() Call cmdNuevo_Click End Sub Private Sub mnuSalir_Click() Unload Me End Sub Private Sub mnuSonido_Click() mnuSonido.Checked = Not (mnuSonido.Checked) End Sub Private Sub picFondo_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) L = IIf(Button = vbLeftButton, IIf(L = 0, 1, 0), IIf(L = 1, 2, 0)) R = IIf(Button = vbRightButton, IIf(R = 0, 1, 0), IIf(R = 1, 2, 0)) End Sub Private Sub picFondo_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If L = 2 Or R = 2 Then 'Acción Dim xT%, yT%, Ind%, Inc% yT = Fix((Y / cmd(0).Height)) xT = Fix((X / cmd(0).Width) + 1) Ind = (yT * (a + 2)) + xT Inc = 0 On Error Resume Next If Ind - (a + 2) > 0 Then If cmd(Ind - (a + 2) - 1).Picture = ImgMarca.Picture Then Inc = Inc + 1 If cmd(Ind - (a + 2)).Picture = ImgMarca.Picture Then Inc = Inc + 1 If cmd(Ind - (a + 2) + 1).Picture = ImgMarca.Picture Then Inc = Inc + 1 End If If Ind > 0 And Ind < T Then If cmd(Ind - 1).Picture = ImgMarca.Picture Then Inc = Inc + 1 If cmd(Ind + 1).Picture = ImgMarca.Picture Then Inc = Inc + 1 End If If Ind + (a + 2) < T Then If cmd(Ind + (a + 2) - 1).Picture = ImgMarca.Picture Then Inc = Inc + 1 If cmd(Ind + (a + 2)).Picture = ImgMarca.Picture Then Inc = Inc + 1 If cmd(Ind + (a + 2) + 1).Picture = ImgMarca.Picture Then Inc = Inc + 1 End If '¡¡¡¡¡¡ If Val(cmd(Ind).Tag) <> Inc Then Exit Sub Call cmd_MouseUp(Ind - (a + 2) - 1, vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Ind - (a + 2)), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Ind - (a + 2) + 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Ind - 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Ind + 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Ind + (a + 2) - 1), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Ind + (a + 2)), vbLeftButton, 0, 0, 0) Call cmd_MouseUp((Ind + (a + 2) + 1), vbLeftButton, 0, 0, 0) On Error GoTo 0 End If L = 0: R = 0 End Sub Private Sub Timer1_Timer() lblTiempo.Caption = Format$(Val(lblTiempo.Caption) + 1, "000") End SubMe gusta mucho usar esto de la recursividad y es por eso que cuando voy a programar siempre pienso en esto, es por esto que ven varias funciones que luego me pueden servir para otras aplicaciones.
Espero que esto les sirva y gracias Guille por todo el empeño que le dedicas a este sitio, yo me inicie con tu tutorial de vb6 y de verdad te digo que me considero un Anakin tuyo. ^_^
Y si por ahi alguien me quisiera mandar sus sugerencias o arreglos sobre el código, que me escriban a mi correo renzo_otakuxp@hotmail.com.
Lo que no nos mata, nos hace más fuertes
Fichero con el código de ejemplo: rzo_buscaminas.zip - Tamaño 26.5 KB
