winmine.cls

VB做的模仿WINDOWS的扫雷游戏

'           inY:        Y co-ordinate of mouse cursor position                      '
'                                                                                   '
' Returns:  None                                                                    '
'                                                                                   '
'***********************************************************************************'
Public Sub EndHitTest(intButton As Integer, intX As Single, intY As Single)
    
    ' if currently processing a mouse click ...
    If mblnHitTestBegun Then
        ' reset the flag
        mblnHitTestBegun = False
    Else
        ' if not, abort. This makes sure that the code below is executed only
        ' when a mouse button is pressed.
        Exit Sub
    End If
    
    Dim blnLeftDown As Boolean
    blnLeftDown = (intButton And LEFT_BUTTON) > 0

    ' if left mouse button pressed ...
    If blnLeftDown Then
        
        ' Calculate row and col grid co-ords from the clicked mouse co-ords
        intX = Int(intX / mintButtonWidth)
        intY = Int(intY / mintButtonHeight)

        ' abort, if  co-ords lie outside minefield
        If intX >= mintCols Or intY >= mintRows Or intX < 0 Or intY < 0 Then
            Exit Sub
        End If

        ' abort, if current square, over which mouse is released has been
        ' marked with a flag
        If mbytMarked(intY, intX) >= FLAGGED Then Exit Sub

        ' Calculate the grid co-ords from last valid mouse cursor co-ords
        intX = mintCol \ mintButtonWidth
        intY = mintRow \ mintButtonHeight
    
        If mbytMarked(intY, intX) = QUESTION Then
            mfrmDisplay.imgQsPressed.Visible = False
        Else
            mfrmDisplay.imgPressed.Visible = False
        End If
        
        Select Case mbytMineStatus(intY, intX)

            Case Is >= BEEN:    ' abort, if current square has already been opened
                                Exit Sub
            
            Case NONE:  ' if current square is empty, iteratively open all
                        ' surrounding squares until non-empty squares are reached
                        OpenBlanks intX, intY
                        
            Case MINE:  ' if current square contains a mine, you blew it!
                        Dim intXm As Integer        ' X co-ord of mine location
                        Dim intYm As Integer        ' Y co-ord of mine location
                        Dim vntCoord As Variant     ' variant used in For Each loop
                        Dim i As Integer            ' Loop counter
                
                        ' reveal all the squares that contain mines
                        For i = 0 To mbytNumMines - 1
                            
                            intYm = mbytMineLocations(i, 0)
                            intXm = mbytMineLocations(i, 1)

                            If mbytMarked(intYm, intXm) < FLAGGED Then
                                mfrmDisplay.PaintPicture mfrmDisplay.imgMine, intXm * mintButtonWidth, intYm * mintButtonHeight
                            End If
                        
                        Next

                        ' display the current square as a blown mine
                        mfrmDisplay.PaintPicture mfrmDisplay.imgBlown, mintCol, mintRow
                        
                        ' reveal all the squares that were wrongly marked as mines
                        For Each vntCoord In mcolWrongLocations

                            intYm = vntCoord.mintY
                            intXm = vntCoord.mintX

                            mfrmDisplay.PaintPicture mfrmDisplay.imgWrongMine, intXm * mintButtonWidth, intYm * mintButtonHeight
                        
                        Next
                        
                        ' prepare for new game
                        mblnNewGame = True
                        
                        Dim CRLF As String
                        CRLF = Chr$(13) & Chr$(10)
                        
                        MsgBox "You Lose!", vbExclamation, "WinMine"

            Case Else:  ' if current square surrounds one or more squares that contains a mine
                        ' reveal the number of such mines that surrounds it
                        mfrmDisplay.PaintPicture mfrmDisplay.imgPressed, mintCol, mintRow
                        mfrmDisplay.CurrentX = mintCol
                        mfrmDisplay.CurrentY = mintRow
                        mfrmDisplay.ForeColor = QBColor(mbytMineStatus(intY, intX))
                        mfrmDisplay.Print mbytMineStatus(intY, intX)
                        
                        ' and mark it as being opened
                        mbytMineStatus(intY, intX) = mbytMineStatus(intY, intX) + BEEN
    
        End Select
    
    End If

End Sub
'***********************************************************************************'
'                                                                                   '
' Purpose:  Does other important stuff like calculate the size of the display form  '
'           when the form object used for display is passed to the class by         '
'           assigning it to this property procedure. Called in the form load event  '
'           of the main display form.                                               '
'                                                                                   '
' Inputs:   frmDisplay: The form object that is used as the main display form       '
' Returns:  None                                                                    '
'                                                                                   '
'***********************************************************************************'
Public Property Set frmDisplay(frmDisplay As Form)
    
    Set mfrmDisplay = frmDisplay
    mfrmDisplay.FontBold = True
    
    ' Resize the form to fit the chosen game level's minefield dimensions
    ResizeDisplay
    
End Property
'***********************************************************************************'
'                                                                                   '
' Purpose:  Displays the values for the number of rows, columns and mines from the  '
'           current game level, in the textboxes of the custom dialog box           '
'                                                                                   '
' Inputs:   frmDialog:  The modal form object that is used as the custom dialog box '
' Returns:  None                                                                    '
'                                                                                   '
'***********************************************************************************'
Public Sub GetMineFieldDimensions(frmDialog As Form)

    frmDialog.txtRows = mintRows
    frmDialog.txtColumns = mintCols
    frmDialog.txtMines = mbytNumMines
    
    frmDialog.txtRows.SelLength = Len(frmDialog.txtRows)
    frmDialog.txtColumns.SelLength = Len(frmDialog.txtColumns)
    frmDialog.txtMines.SelLength = Len(frmDialog.txtMines)

End Sub
'***********************************************************************************'
'                                                                                   '
' Purpose:  Allocates memory for dynamic arrays according to current minefield      '
'           dimensions and sets up the mine locations in the minefield              '
'                                                                                   '
' Inputs:   None                                                                    '
' Returns:  None                                                                    '
'                                                                                   '
'***********************************************************************************'
Private Sub InitializeMineField()
    
    ' allocate space for the 2D dynamic arrays to fit the current
    ' minefield size
    ReDim mbytMineStatus(mintRows - 1, mintCols - 1)
    ReDim mbytMarked(mintRows - 1, mintCols - 1)
    ReDim mbytMineLocations(mbytNumMines - 1, 1)

    ' Generate random mine locations in the minefield and store them in
    ' the mbytMineLocations array. Also fill the mbytMineStatus array with
    ' info as to which squares contain mines and which are the ones that
    ' indicate surrounding mines
    Randomize

    Dim i As Integer    ' Loop counter
    Dim r As Integer    ' Loop counter
    Dim c As Integer    ' Loop counter

    For i = 0 To mbytNumMines - 1

        Dim intX As Integer
        Dim intY As Integer

        intX = Int(Rnd * mintCols)
        intY = Int(Rnd * mintRows)

        While mbytMineStatus(intY, intX) = MINE
            intX = Int(Rnd * mintCols)
            intY = Int(Rnd * mintRows)
        Wend

        mbytMineStatus(intY, intX) = MINE
        mbytMineLocations(i, 0) = intY
        mbytMineLocations(i, 1) = intX

        For r = -1 To 1
            For c = -1 To 1

                Dim blnDx As Boolean
                Dim blnDy As Boolean

                blnDy = intY + r >= 0 And intY + r < mintRows
                blnDx = intX + c >= 0 And intX + c < mintCols

                If blnDy And blnDx Then
                    If mbytMineStatus(intY + r, intX + c) <> MINE Then
                        mbytMineStatus(intY + r, intX + c) = mbytMineStatus(intY + r, intX + c) + 1
                    End If
                End If

            Next
        Next

    Next

End Sub
'***********************************************************************************'
'                                                                                   '
' Purpose:  Prepares for a new game                                                 '
' Inputs:   None                                                                    '
' Returns:  None                                                                    '
'                                                                                   '
'***********************************************************************************'
Public Sub NewGame()
    
    ' clear the current display in the main form
    mfrmDisplay.Cls
 
    ' reset game variables and flags
    mbytCorrectHits = 0
    mbytTotalHits = 0

    mintRow = -1
    mintCol = -1

    mblnNewGame = False
    mblnHitTestBegun = False
    
    Dim i As Integer            ' Loop counter

    ' empty the collection of wrong co-ords
    For i = 1 To mcolWrongLocations.Count
        mcolWrongLocations.Remove 1
    Next
    
    ' re-calculate new mine locations
    InitializeMineField
    
    ' Reset the display of number of mines left
    mfrmDisplay.lblMinesLeft = "Mines Left : " & mbytNumMines
    
End Sub
'***************************************************************************************'
'                                                                                       '
' Purpose:  If the square that was clicked was empty, then this function iteratively    '
'           opens all squares surrounding it, until non-empty squares are encountered   '
'           A general fill algorithm is adopted here, wherein, the current square       '
'           location keeps moving left, until it comes across a non-empty square. From  '
'           here onwards, it tries to trace out a border of non-empty squares by moving '
'           clockwise in the directions where it can go. At the same time it stores the '
'           pairs of starting and ending X co-ords on each scanline that crosses the    '
'           region enclosed by the traced out border.                                   '
'                                                                                       '
' Inputs:   inX:    X grid co-ordinate of the square where the mouse was clicked        '
'           inY:    Y grid co-ordinate of the square where the mouse was clicked        '
'                                                                                       '
' Returns:  None                                                                        '
'                                                                                       '
'***********************************************************************************'***'
Private Sub OpenBlanks(ByVal intX As Single, ByVal intY As Single)

    ' flags to keep track of the direction in which current square moves
    Dim blnGoUp As Boolean
    Dim blnGoRight As Boolean
    Dim blnGoDown As Boolean