Vb扫雷程序代码

Private objMine As New clsWinMinePrivate Sub Form_Load() Set objMine.frmDisplay = MeEnd SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 判断单击的是哪个区域 objMine.BeginHitTest Button, x, yEnd SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 判断当鼠标左键按下的时候鼠标指针在哪个区域 objMine.TrackHitTest Button, x, yEnd SubPrivate Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 判断释放鼠标左键的时候鼠标指针在哪个区域 objMine.EndHitTest Button, x, yEnd SubPrivate Sub mnuBeginner_Click() mnuBeginner.Checked = True mnuIntermediate.Checked = False mnuExpert.Checked = False mnuCustom.Checked = False 初级模式 objMine.SetMineFieldDimension 8, 8, 10, False objMine.mblnNewGame = True End SubPrivate Sub mnuCustom_Click() mnuBeginner.Checked = False mnuIntermediate.Checked = False mnuExpert.Checked = False mnuCustom.Checked = True 中级模式 objMine.GetMineFieldDimensions frmCustomDlg frmCustomDlg.Show 1 如果按ESC键，则退出 If frmCustomDlg.mblnEscape Then Exit Sub objMine.SetMineFieldDimension Val(frmCustomDlg.txtRows), Val(frmCustomDlg.txtColumns), Val(frmCustomDlg.txtMines), True 卸载隐藏的对话框 Unload frmCustomDlg 做好准备开始新游戏 objMine.mblnNewGame = TrueEnd SubPrivate Sub mnuExit_Click() 调用terminate事件 Set objMine = Nothing 退出游戏 EndEnd SubPrivate Sub mnuExpert_Click() mnuBeginner.Checked = False mnuIntermediate.Checked = False mnuExpert.Checked = True mnuCustom.Checked = False 高级模式 objMine.SetMineFieldDimension 16, 30, 100, False objMine.mblnNewGame = TrueEnd SubPrivate Sub mnuIntermediate_Click() mnuBeginner.Checked = False mnuIntermediate.Checked = True mnuExpert.Checked = False mnuCustom.Checked = False 自定义模式 objMine.SetMineFieldDimension 16, 16, 40, False objMine.mblnNewGame = TrueEnd SubPrivate Sub mnuNew_Click() 开始新游戏 objMine.NewGameEnd SubOption Explicit 判断左键是否按下Private Const LEFT_BUTTON As Byte = 1 标记没有地雷的区域Private Const NONE As Byte = 0 标记是否触雷Private Const MINE As Byte = 243 已经清除地雷的区域Private Const BEEN As Byte = 244 标记确定已经有地雷的区域Private Const FLAGGED As Byte = 2 标记可疑区域Private Const QUESTION As Byte = 1 最大、最小行列数Private Const MIN_MINES As Byte = 10Private Const MAX_MINES As Byte = 99Private Const MIN_ROWS As Integer = 8Private Const MAX_ROWS As Integer = 24Private Const MIN_COLS As Integer = 8Private Const MAX_COLS As Integer = 36 宽Private Const mintButtonWidth As Byte = 16 高Private Const mintButtonHeight As Byte = 16 总地雷数Private mbytNumMines As Byte 尚未标记的地雷数Private mbytCorrectHits As Byte 已经标记出的雷数（包括错误的）Private mbytTotalHits As Byte 不同等级游戏的总行列数Private mintRows As IntegerPrivate mintCols As IntegerPrivate mintRow As IntegerPrivate mintCol As Integer 标记是否开始新游戏Public mblnNewGame As Boolean 标记一个鼠标单击事件正在进行Private mblnHitTestBegun As BooleanPrivate mfrmDisplay As FormPrivate mbytMineStatus() As BytePrivate mbytMarked() As BytePrivate mbytMineLocations() As BytePrivate mcolWrongLocations As New CollectionPublic Sub BeginHitTest(intButton As Integer, intX As Single, intY As Single) 如果当前游戏结束则开始新的游戏 If mblnNewGame Then NewGame End If mblnHitTestBegun = True 根据位图计算栅格大小 intX = Int(intX / mintButtonWidth) intY = Int(intY / mintButtonHeight) 退出 If intX = mintCols _ Or intY = mintRows _ Or intX 0 _ Or intY = BEEN Then Exit Sub Dim blnLeftDown As Boolean blnLeftDown = (intButton And LEFT_BUTTON) 0 如果左键单击 If blnLeftDown Then 如果该区域已经清除干净，则单击无效 If mbytMarked(intY, intX) = FLAGGED Then Exit Sub If mbytMarked(intY, intX) = QUESTION Then mfrmDisplay.imgPressed.Visible = False mfrmDisplay.imgQsPressed.Visible = False mfrmDisplay.imgQsPressed.Left = mintCol mfrmDisplay.imgQsPressed.Top = mintRow mfrmDisplay.imgQsPressed.Visible = True Else mfrmDisplay.imgQsPressed.Visible = False mfrmDisplay.imgPressed.Visible = False mfrmDisplay.imgPressed.Left = mintCol mfrmDisplay.imgPressed.Top = mintRow mfrmDisplay.imgPressed.Visible = True End If Else 如果右键单击 Dim Msg As String Dim CRLF As String CRLF = Chr$(13) & Chr$(10) Select Case mbytMarked(intY, intX) Case NONE: If mbytTotalHits = mbytNumMines Then Msg = 不能标记更多的雷！ & CRLF Msg = Msg & 一个或多个雷标记错误。 & CRLF Msg = Msg & 单击鼠标右键取消某些雷的标记。 MsgBox Msg, vbCritical, WinMine: Error! Exit Sub End If 如果不做标记，则显示一个准备标记的图标 mfrmDisplay.PaintPicture mfrmDisplay.imgFlag, mintCol, mintRow 增加已标记地雷的总数 mbytTotalHits = mbytTotalHits + 1 mfrmDisplay.lblMinesLeft = _ Mines Left : & mbytNumMines - mbytTotalHits 如果标记正确 If mbytMineStatus(intY, intX) = MINE Then mbytCorrectHits = mbytCorrectHits + 1 mbytMarked(intY, intX) = FLAGGED Else 如果标记错误 Dim objCoords As New clsCoords objCoords.mintX = intX objCoords.mintY = intY mcolWrongLocations.Add objCoords mbytMarked(intY, intX) = _ mbytTotalHits - mbytCorrectHits + 2 End If 如果所有地雷都正确的标记出来 If mbytCorrectHits = mbytNumMines Then Msg = 太棒了！ & CRLF Msg = Msg & 你赢了！ & CRLF MsgBox Msg, vbInformation, WinMine 准备开始新游戏 mblnNewGame = True End If Case QUESTION: 如果标记位置已做其他标记 mbytMarked(intY, intX) = NONE 显示区域不变 mfrmDisplay.PaintPicture _ mfrmDisplay.imgButton, mintCol, mintRow Case Else: mfrmDisplay.PaintPicture _ mfrmDisplay.imgQuestion, mintCol, mintRow 总数减1 mbytTotalHits = mbytTotalHits - 1 刷新 mfrmDisplay.lblMinesLeft = _ Mines Left : & mbytNumMines - mbytTotalHits 如果当前标记区域有地雷 If mbytMineStatus(intY, intX) = MINE Then 总数减1 mbytCorrectHits = mbytCorrectHits - 1 Else 如果标记错误 mcolWrongLocations.Remove mbytMarked(intY, intX) - 2 Dim intXwm As Integer Dim intYwm As Integer Dim i As Integer For i = mbytMarked(intY, intX) - 2 _ To mcolWrongLocations.Count intXwm = mcolWrongLocations(i).mintX intYwm = mcolWrongLocations(i).mintY mbytMarked(intYwm, intXwm) = _ mbytMarked(intYwm, intXwm) - 1 Next End If mbytMarked(intY, intX) = QUESTION End Select End IfEnd SubPublic Sub EndHitTest(intButton As Integer, intX As Single, intY As Single) If mblnHitTestBegun Then 重置标记 mblnHitTestBegun = False Else Exit Sub End If Dim blnLeftDown As Boolean blnLeftDown = (intButton And LEFT_BUTTON) 0 如果鼠标左键按下 If blnLeftDown Then 计算行列数 intX = Int(intX / mintButtonWidth) intY = Int(intY / mintButtonHeight) If intX = mintCols Or intY = mintRows _ Or intX 0 Or intY = FLAGGED Then Exit Sub 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: Exit Sub Case NONE: OpenBlanks intX, intY Case MINE: Dim intXm As Integer Dim intYm As Integer Dim vntCoord As Variant Dim i As Integer For i = 0 To mbytNumMines - 1 intYm = mbytMineLocations(i, 0) intXm = mbytMineLocations(i, 1) If mbytMarked(intYm, intXm) = 0 And intY + r = 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 NextEnd SubPublic Sub NewGame() 清除窗体 mfrmDisplay.Cls 重置所有变量 mbytCorrectHits = 0 mbytTotalHits = 0 mintRow = -1 mintCol = -1 mblnNewGame = False mblnHitTestBegun = False Dim i As Integer For i = 1 To mcolWrongLocations.Count mcolWrongLocations.Remove 1 Next InitializeMineField mfrmDisplay.lblMinesLeft = Mines Left : & mbytNumMinesEnd Sub打开雷区Private Sub OpenBlanks(ByVal intX As Single, ByVal intY As Single) Dim blnGoUp As Boolean Dim blnGoRight As Boolean Dim blnGoDown As Boolean Dim blnGoLeft As Boolean Dim intXStart As Integer Dim intYStart As Integer Dim intPos As Integer Dim element As Variant Dim y As Integer Dim x As Integer Dim i As Integer Dim colX() As New Collection ReDim colX(mintRows - 1) While mbytMineStatus(intY, intX) = NONE intX = intX - 1 If intX 0 Then intX = 0 intXStart = intX intYStart = intY GoTo LFT End If Wend blnGoUp = True intXStart = intX intYStart = intY Do If mbytMineStatus(intY, intX) = NONE Then If blnGoUp Then intX = intX - 1 intY = intY + 1 colX(intY).Remove (colX(intY).Count) blnGoUp = False blnGoLeft = True ElseIf blnGoRight Then intX = intX - 1 intY = intY - 1 blnGoRight = False blnGoUp = True ElseIf blnGoDown Then intX = intX + 1 intY = intY - 1 colX(intY).Remove (colX(intY).Count) blnGoDown = False blnGoRight = True ElseIf blnGoLeft Then intX = intX + 1 intY = intY + 1 blnGoLeft = False blnGoDown = True End If If (intXStart = intX And intYStart = intY) Then Exit Do Else If blnGoUp Then colX(intY).Add intX If mbytMineStatus(intY, intX + 1) = NONE Then If intY = 0 Then blnGoUp = FalseUP: intX = intX + 1 If (intXStart = intX And intYStart = intY) _ Then Exit Do While mbytMineStatus(intY, intX) = NONE If intX = mintCols - 1 Then GoTo RIGHT intX = intX + 1 If (intXStart = intX And intYStart = intY) _ Then Exit Do Wend blnGoDown = True Else intY = intY - 1 If (intXStart