扫雷

'           CopyRight (C) 2003 ZMSPU     小小数点敬赠 '----------------------------------------------------------------------- '标志说明 '           0 ～  9 未打开的 '          -1 ～ -9 已打开的 '           10      雷 '           11      已打开的空（未判断） '           12      已打开的空（已判断） '           13      标记过的 '           14      问号 ' Dim What(1 To 30, 1 To 16) As Long     '点 Dim Save(1 To 30, 1 To 16) As Long     '存 Dim mX As Long Dim mY As Long                      '坐标 Dim mTime As Long Dim MineFlag As Long                '标记雷 Dim OpenFlag As Long                '已打开的 Dim NowWidth As Long Dim NowHeight As Long Dim TotMine As Long                 '总雷数 Private Sub Command1_Click() Timer1.Enabled = True Label2 = "00:00" Label1 = TotMine Label3 = "加油哦，祝你好运！！！" Picture1.Enabled = True For X = 0 To NowWidth - 1     For Y = 0 To NowHeight - 1         Picture1.PaintPicture image1(9).Picture, X, Y     Next Next ClearStart NowWidth, NowHeight, TotMine WriteNumber NowWidth, NowHeight End Sub Private Sub Command2_Click() If Command2.Caption = "显示源代码" Then    Command2.Caption = "隐藏源代码"    Frame2.Visible = True Else    Command2.Caption = "显示源代码"    Frame2.Visible = False End If End Sub Private Sub Form_Load() Dim X As Long Dim Y As Long Show NowHeight = 16 NowWidth = 30 TotMine = 40 Picture1.Height = (image1(0).Height) * NowHeight Picture1.Width = (image1(0).Width) * NowWidth Picture1.ScaleMode = 3 Picture1.ScaleHeight = NowHeight Picture1.ScaleWidth = NowWidth For X = 0 To NowWidth - 1     For Y = 0 To NowHeight - 1         Picture1.PaintPicture image1(9).Picture, X, Y     Next Next ClearStart NowWidth, NowHeight, TotMine WriteNumber NowWidth, NowHeight Exit Sub '-------------------------- For X = 1 To NowWidth     For Y = 1 To NowHeight         If What(X, Y) = 10 Then            Picture1.PaintPicture image1(13).Picture, X - 1, Y - 1         ElseIf What(X, Y) >= 1 And What(X, Y) <= 9 Then            Picture1.PaintPicture image1(What(X, Y)).Picture, X - 1, Y - 1         Else            Picture1.PaintPicture image1(9).Picture, X - 1, Y - 1         End If     Next Next End Sub Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim T As Long Dim X1 As Long Dim Y1 As Long Dim x2 As Single Dim y2 As Single mX = Int(X) mY = Int(Y) If Button = vbLeftButton Then    '左键按下    If What(mX + 1, mY + 1) >= 0 And What(mX + 1, mY + 1) <= 10 Then       Picture1.PaintPicture image1(14).Picture, mX, mY    End If ElseIf Button = vbRightButton Then    '右键按下    '只有是打开的才处理  If What(mX + 1, mY + 1) >= -9 And What(mX + 1, mY + 1) <= -1 Then    T = 0    '计算标记的雷    For X1 = mX To mX + 2        For Y1 = mY To mY + 2            If X1 = mX + 1 And Y1 = mY + 1 Then            Else               If X1 >= 1 And X1 <= NowWidth Then                  If Y1 >= 1 And Y1 <= NowHeight Then                     If What(X1, Y1) = 13 Then                        T = T + 1                     End If                  End If               End If            End If        Next    Next    '如果标记数大于等于雷数则不处理    If T >= -(What(mX + 1, mY + 1)) Then Exit Sub    '如果标记数等于雷数则打开    If T = -What(mX + 1, mY + 1) Then    For X1 = mX To mX + 2        For Y1 = mY To mY + 2            If X1 = mX + 1 And Y1 = mY + 1 Then            Else               If X1 >= 1 And X1 <= NowWidth Then                  If Y1 >= 1 And Y1 <= NowHeight Then                     x2 = X1: y2 = Y1                     Picture1_MouseUp vbLeftButton, 0, x2, y2                  End If               End If                          End If        Next    Next       Exit Sub    End If    '如果标记数小于雷数则按下余下的    For X1 = mX To mX + 2        For Y1 = mY To mY + 2            If X1 = mX + 1 And Y1 = mY + 1 Then            Else               If X1 >= 1 And X1 <= NowWidth Then                  If Y1 >= 1 And Y1 <= NowHeight Then                     If What(X1, Y1) >= 0 And What(X1, Y1) <= 10 Then '                       Picture1.PaintPicture image1(14).Picture, X1 - 1, Y1 - 1 '                       Picture1.PaintPicture image1(9).Picture, X1 - 1, Y1 - 1                     End If                  End If               End If                          End If        Next    Next   End If End If End Sub Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbLeftButton Then    '左击    If What(mX + 1, mY + 1) = 10 Then       '点到雷       Timer1.Enabled = False       Picture1.PaintPicture image1(13).Picture, mX, mY       Picture1.Enabled = False       Label3 = "哇！你点到雷了呀！重来吧！！！"       EndGame       Timer1 = False       Picture1.Enabled = False       Exit Sub    ElseIf What(mX + 1, mY + 1) >= 1 And What(mX + 1, mY + 1) <= 9 Then       '点到数字       OpenFlag = OpenFlag + 1       Picture1.PaintPicture image1(What(mX + 1, mY + 1)).Picture, mX, mY       What(mX + 1, mY + 1) = -What(mX + 1, mY + 1)    ElseIf What(mX + 1, mY + 1) = 0 Then       '点到空       Picture1.PaintPicture image1(0).Picture, mX, mY       What(mX + 1, mY + 1) = 11       OpenBlank mX + 1, mY + 1    End If    If MineFlag + OpenFlag = NowHeight * NowWidth Then       Label3 = "恭喜恭喜！你过关了！"       Timer1.Enabled = False       Picture1.Enabled = False    End If ElseIf Button = vbRightButton Then    '右击    If What(mX + 1, mY + 1) >= 0 And What(mX + 1, mY + 1) <= 10 Then       '未标记过的进行标记       Save(mX + 1, mY + 1) = What(mX + 1, mY + 1)       What(mX + 1, mY + 1) = 13       Picture1.PaintPicture image1(10).Picture, mX, mY       MineFlag = MineFlag + 1       Label1 = TotMine - MineFlag    ElseIf What(mX + 1, mY + 1) = 13 Then       '已经标记过则改为?       What(mX + 1, mY + 1) = 14       MineFlag = MineFlag - 1       Label1 = TotMine - MineFlag       Picture1.PaintPicture image1(11).Picture, mX, mY    ElseIf What(mX + 1, mY + 1) = 14 Then       '标记过?号的则       What(mX + 1, mY + 1) = Save(mX + 1, mY + 1)       Picture1.PaintPicture image1(9).Picture, mX, mY    End If End If End Sub Private Sub ClearStart(ByVal mWidth As Long, ByVal mHeight As Long, ByVal MineNumber As Long) '预置雷位置 Randomize mTime = 0 MineFlag = 0 OpenFlag = 0 '清空数组 Erase What For T = 1 To MineNumber aa:     '任意取一个坐标(X,Y)     X = Rnd * (mWidth - 1)     Y = Rnd * (mHeight - 1)     '如果已经取过该坐标则重新再取     If What(X + 1, Y + 1) = 10 Then GoTo aa     '将当前坐标标记为有雷     What(X + 1, Y + 1) = 10     Save(X + 1, Y + 1) = 10 Next End Sub Private Sub WriteNumber(ByVal mWidth As Long, ByVal mHeight As Long) '写入信息 Dim X As Long Dim Y As Long Dim StartX As Long Dim StartY As Long Dim EndX As Long Dim EndY As Long Dim T As Long Dim TT Dim mNumber As Long For X = 1 To mWidth     '从当前列的上一列开始     StartX = X - 1     If StartX = 0 Then StartX = 1     '在当前列的下一列结束     EndX = X + 1     If EndX > mWidth Then EndX = mWidth     For Y = 1 To mHeight         '如果当前位置不是雷则开始计算         If What(X, Y) <> 10 Then            '从当前行的上一行开始            StartY = Y - 1            If StartY = 0 Then StartY = 1            '在当前行的下一行结束            EndY = Y + 1            If EndY > mHeight Then EndY = mHeight            '累加器置0            mNumber = 0            '计算四周有多少颗雷            For T = StartX To EndX                For TT = StartY To EndY                    If TT = Y And T = X Then                      '如果是当前位置则不计入                                       Else                       '如果是雷则计入                       If What(T, TT) = 10 Then mNumber = mNumber + 1                    End If                Next           Next           If mNumber = 0 Then              '如果没有雷在其四周则打开当前位置              What(X, Y) = 0              Save(X, Y) = 0           Else              '写入雷数              What(X, Y) = mNumber              Save(X, Y) = mNumber           End If        End If     Next Next End Sub Private Sub Timer1_Timer() Dim sTime As String Dim mM As Long Dim mS As Long Dim sM As String Dim sS As String mTime = mTime + 1 mM = Int(mTime / 60) mS = mTime - mM sS = mS sM = mM If mM < 10 Then sM = "0" ‑ mM If mS < 10 Then sS = "0" ​ mS Label2 = sM ‑ ":" ​ sS End Sub Private Sub OpenBlank(ByVal zmX As Long, ByVal zmY As Long) Dim Continue As Boolean Dim mX As Long Dim mY As Long OpenFlag = OpenFlag + 1 Do While True    Continue = False    For mY = 1 To NowHeight        For mX = 1 To NowWidth            If What(mX, mY) = 11 Then               '如果存在未判断的空               Continue = True               '把它周围的8个点打开               '先打开左面的点               If mX - 1 >= 1 Then                  If What(mX - 1, mY) = 0 Then                     What(mX - 1, mY) = 11                     Picture1.PaintPicture image1(0).Picture, mX - 2, mY - 1                     OpenFlag = OpenFlag + 1                  ElseIf What(mX - 1, mY) >= 1 And What(mX - 1, mY) <= 9 Then                     Picture1.PaintPicture image1(What(mX - 1, mY)).Picture, mX - 2, mY - 1                     What(mX - 1, mY) = -What(mX - 1, mY)                     OpenFlag = OpenFlag + 1                  End If               End If               '打开左上的点               If mX - 1 >= 1 And mY - 1 >= 1 Then                     If What(mX - 1, mY - 1) = 0 Then                        What(mX - 1, mY - 1) = 11                        Picture1.PaintPicture image1(0).Picture, mX - 2, mY - 2                        OpenFlag = OpenFlag + 1                     ElseIf What(mX - 1, mY - 1) >= 1 And What(mX - 1, mY - 1) <= 9 Then                        Picture1.PaintPicture image1(What(mX - 1, mY - 1)).Picture, mX - 2, mY - 2                        What(mX - 1, mY - 1) = -What(mX - 1, mY - 1)                        OpenFlag = OpenFlag + 1                     End If               End If               '再打开上面的点               If mY - 1 >= 1 Then                  If What(mX, mY - 1) = 0 Then                     What(mX, mY - 1) = 11                     Picture1.PaintPicture image1(0).Picture, mX - 1, mY - 2                     OpenFlag = OpenFlag + 1                  ElseIf What(mX, mY - 1) >= 1 And What(mX, mY - 1) <= 9 Then                     Picture1.PaintPicture image1(What(mX, mY - 1)).Picture, mX - 1, mY - 2                     What(mX, mY - 1) = -What(mX, mY - 1)                     OpenFlag = OpenFlag + 1                  End If               End If               '打开右上的点               If mY - 1 >= 1 And mX + 1 <= NowWidth Then                     If What(mX + 1, mY - 1) = 0 Then                        What(mX + 1, mY - 1) = 11                        Picture1.PaintPicture image1(0).Picture, mX, mY - 2                        OpenFlag = OpenFlag + 1                     ElseIf What(mX + 1, mY - 1) >= 1 And What(mX + 1, mY - 1) <= 9 Then                        Picture1.PaintPicture image1(What(mX + 1, mY - 1)).Picture, mX, mY - 2                        What(mX + 1, mY - 1) = -What(mX + 1, mY - 1)                        OpenFlag = OpenFlag + 1                     End If               End If               '再打开右面的点               If mX + 1 <= NowWidth Then                  If What(mX + 1, mY) = 0 Then                     What(mX + 1, mY) = 11                     Picture1.PaintPicture image1(0).Picture, mX, mY - 1                     OpenFlag = OpenFlag + 1                  ElseIf What(mX + 1, mY) >= 1 And What(mX + 1, mY) <= 9 Then                     Picture1.PaintPicture image1(What(mX + 1, mY)).Picture, mX, mY - 1                     What(mX + 1, mY) = -What(mX + 1, mY)                     OpenFlag = OpenFlag + 1                  End If               End If               '再打开右下的点               If mY + 1 <= NowHeight And mX + 1 <= NowWidth Then                     If What(mX + 1, mY + 1) = 0 Then                        What(mX + 1, mY + 1) = 11                        Picture1.PaintPicture image1(0).Picture, mX, mY                        OpenFlag = OpenFlag + 1                     ElseIf What(mX + 1, mY + 1) >= 1 And What(mX + 1, mY + 1) <= 9 Then                        Picture1.PaintPicture image1(What(mX + 1, mY + 1)).Picture, mX, mY                        What(mX + 1, mY + 1) = -What(mX + 1, mY + 1)                        OpenFlag = OpenFlag + 1                     End If               End If               '打开下面的点               If mY + 1 <= NowHeight Then                  If What(mX, mY + 1) = 0 Then                     What(mX, mY + 1) = 11                     Picture1.PaintPicture image1(0).Picture, mX - 1, mY                     OpenFlag = OpenFlag + 1                  ElseIf What(mX, mY + 1) >= 1 And What(mX, mY + 1) <= 9 Then                     Picture1.PaintPicture image1(What(mX, mY + 1)).Picture, mX - 1, mY                     What(mX, mY + 1) = -What(mX, mY + 1)                     OpenFlag = OpenFlag + 1                  End If               End If               '最后打开左下的点               If mY + 1 <= NowHeight And mX - 1 >= 1 Then                     If What(mX - 1, mY + 1) = 0 Then                        What(mX - 1, mY + 1) = 11                        Picture1.PaintPicture image1(0).Picture, mX - 2, mY                        OpenFlag = OpenFlag + 1                     ElseIf What(mX - 1, mY + 1) >= 1 And What(mX - 1, mY + 1) <= 9 Then                        Picture1.PaintPicture image1(What(mX - 1, mY + 1)).Picture, mX - 2, mY                        What(mX - 1, mY + 1) = -What(mX - 1, mY + 1)                        OpenFlag = OpenFlag + 1                     End If               End If               '四点判断完后将本点标记为已判断过               What(mX, mY) = 12            End If        Next    Next    If Continue = False Then Exit Do Loop End Sub Private Sub EndGame() Dim X As Long Dim Y As Long For Y = 1 To NowHeight     For X = 1 To NowWidth         If What(X, Y) = 10 Then            Picture1.PaintPicture image1(13).Picture, X - 1, Y - 1         Else            If What(X, Y) = 13 Then               If Save(X, Y) <> 10 Then                  Picture1.PaintPicture image1(12).Picture, X - 1, Y - 1               End If            ElseIf What(X, Y) = 14 Then               If Save(X, Y) = 10 Then                  Picture1.PaintPicture image1(13).Picture, X - 1, Y - 1               End If            End If         End If     Next Next End Sub