VB扫雷源代码

所属类别：VB
推荐指数：★★★☆
文档人气：1440
本周人气：9
发布日期：2007-2-21

'---------------------------------------------------------------------
'
'扫雷程序源代码 (这个程序只完成了主要的部份,其他细节我想你能完成了.)
'
'
'扫雷程序最难的部份是在于如何自动打开空白区了
'我以前是用“堆栈”的方式进行判断来打开的,
'就是把要判断的坐标压入用集合模拟的堆栈区,然后再逐一弹出进行判断.
'用这种方式一是要用到集合来做堆栈,二是编程烦琐
'我想了很长时间,终于想到另外一种方法,也就是现在用的这种方法
'我暂时称它为"扫描"方法吧,因为它正是用的扫描原理来打开空白区的
'"扫描"方法一是速度快,没有用到集合,另外就是编程方便,易于读懂程序.
'我个人对这种方法比较喜欢的,我觉得它是一个很新的思路(呵呵别笑我笨啊)
'
'你可以任意复制或修改以下代码以满足你的需要,但请注明其出处
'任何问题可以和我联系呀!   Email: ZMSPU@163.COM
'
'           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