Buscaminas hecho en VB6

Fecha: 08/Jun/2005 (08/Jun/05)
Autor: Renzo Galo Castro Jurado - [email protected] 


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:

Buscaminas - RzO

' 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 Sub
    

Me 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 [email protected].

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


ir al índice