frmmain.frm

VB做的扫雷程序

VERSION 5.00
Begin VB.Form frmMain 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00FFFFFF&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "扫雷"
   ClientHeight    =   4440
   ClientLeft      =   150
   ClientTop       =   780
   ClientWidth     =   2280
   Icon            =   "frmMain.frx":0000
   MaxButton       =   0   'False
   ScaleHeight     =   296
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   152
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer tmrTick 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   0
      Top             =   0
   End
   Begin VB.Image imgNumbers 
      Height          =   3840
      Index           =   1
      Left            =   1920
      Picture         =   "frmMain.frx":08CA
      Top             =   120
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imgNumbers 
      Height          =   3840
      Index           =   0
      Left            =   1560
      Picture         =   "frmMain.frx":0E3A
      Top             =   120
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imgFaces 
      Height          =   1800
      Index           =   1
      Left            =   1080
      Picture         =   "frmMain.frx":1476
      Top             =   120
      Visible         =   0   'False
      Width           =   360
   End
   Begin VB.Image imgDigits 
      Height          =   4140
      Index           =   1
      Left            =   360
      Picture         =   "frmMain.frx":196B
      Top             =   120
      Visible         =   0   'False
      Width           =   195
   End
   Begin VB.Image imgFaces 
      Height          =   1800
      Index           =   0
      Left            =   600
      Picture         =   "frmMain.frx":1E4E
      Top             =   120
      Visible         =   0   'False
      Width           =   360
   End
   Begin VB.Image imgDigits 
      Height          =   4140
      Index           =   0
      Left            =   120
      Picture         =   "frmMain.frx":23A7
      Top             =   120
      Visible         =   0   'False
      Width           =   195
   End
   Begin VB.Menu mnuGame 
      Caption         =   "游戏(&G)"
      Begin VB.Menu mnuNew 
         Caption         =   "开局(&N)"
         Shortcut        =   {F2}
      End
      Begin VB.Menu mnuGameBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuLevel 
         Caption         =   "初级(&B)"
         Checked         =   -1  'True
         Index           =   0
      End
      Begin VB.Menu mnuLevel 
         Caption         =   "中级(&I)"
         Index           =   1
      End
      Begin VB.Menu mnuLevel 
         Caption         =   "高级(&E)"
         Index           =   2
      End
      Begin VB.Menu mnuCustomize 
         Caption         =   "自定义(&C)..."
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuGameBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuMark 
         Caption         =   "标记(?)(&M)"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuColor 
         Caption         =   "颜色(&L)"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuSound 
         Caption         =   "声音(&S)"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuGameBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuHighscore 
         Caption         =   "扫雷英雄榜(&T)"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuGameBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出(&X)"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuContents 
         Caption         =   "目录(&C)"
         Enabled         =   0   'False
         Shortcut        =   {F1}
      End
      Begin VB.Menu mnuSearch 
         Caption         =   "查找帮助主题(&S)..."
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuHelpHelp 
         Caption         =   "使用帮助(&H)"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuHelpBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuAbout 
         Caption         =   "关于扫雷(&A)..."
         Enabled         =   0   'False
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const MIN_ROWS As Integer = 9
Private Const MAX_ROWS As Integer = 24
Private Const MIN_COLUMNS As Integer = 9
Private Const MAX_COLUMNS As Integer = 30
Private Const DIGIT_WIDTH As Integer = 13
Private Const DIGIT_HEIGHT As Integer = 23
Private Const FACE_WIDTH As Integer = 24
Private Const FACE_HEIGHT As Integer = 24
Private Const NUMBER_WIDTH As Integer = 16
Private Const NUMBER_HEIGHT As Integer = 16
Private Const LEFT_OFFSET As Integer = 3
Private Const TOP_OFFSET As Integer = 3
Private Const LEFT_MARGIN As Integer = 6
Private Const TOP_MARGIN As Integer = 6
Private Const RIGHT_MARGIN As Integer = 5
Private Const BOTTOM_MARGIN As Integer = 5
Private Const MIDDLE_MARGIN As Integer = 6
Private Const SCORE_FRAME_WIDTH As Integer = 2
Private Const MINE_FRAME_WIDTH As Integer = 3
Private Const FACE_FRAME_WIDTH As Integer = 1
Private Const DIGHT_FRAME_WIDTH As Integer = 1
Private Const REMAINING_FRAME_WIDTH As Integer = 1
Private Const TIME_FRAME_WIDTH As Integer = 1
Private Const SCORE_BOX_HEIGHT As Integer = 37
Private Const REMAINING_BOX_MARGIN As Integer = 5
Private Const TIME_BOX_MARGIN As Integer = 7
Private Const COLOR_BLACK As Long = &H0&
Private Const COLOR_DARKGRAY As Long = &H808080
Private Const COLOR_GRAY As Long = &HC0C0C0
Private Const COLOR_WHITE As Long = &HFFFFFF

Private Enum STATUS
    Gaming = 4
    Lose = 2
    Win = 1
End Enum

Private Type COORD
    Row As Integer
    Column As Integer
End Type

Private Type SEEDT
    Seed As Single
    Row As Integer
    Column As Integer
End Type

Dim m_Width As Integer, m_Height As Integer
Dim m_MineLeft As Integer, m_MineTop As Integer
Dim m_InnerLeft As Integer, m_InnerTop As Integer
Dim m_ScoreBoxTop As Integer, m_DigitBoxTop As Integer
Dim m_RemainingBoxLeft As Integer, m_TimeBoxLeft As Integer
Dim m_MineWidth As Integer, m_MineHeight As Integer
Dim m_FaceLeft As Integer, m_FaceTop As Integer
Dim m_Rows As Integer, m_Columns As Integer, m_Mines As Integer
Dim m_Style As Integer
Dim m_Level As Integer
Dim m_Generated As Boolean

Dim m_Remaining As Integer, m_Uncertain As Integer, m_Time As Integer
Dim m_Data() As Byte, m_Buffer() As Byte
Dim m_Status As STATUS
Dim m_Button As Integer, m_Shift As Integer
Dim m_FaceClick As Boolean
Dim m_LastPosition As COORD

Dim m_Mark As Boolean

Private Sub DrawDigits(ByVal Number As Integer, ByVal Count As Integer, ByVal X As Integer, ByVal Y As Integer)
    Dim bMinus As Boolean
    If Number < 0 Then
        Number = -Number
        bMinus = True
    End If
    Do While Count <> 0
        Count = Count - 1
        If bMinus = True And Count = 0 Then
            PaintPicture imgDigits(m_Style).Picture, X + Count * DIGIT_WIDTH, Y, DIGIT_WIDTH, DIGIT_HEIGHT, 0, 0, DIGIT_WIDTH, DIGIT_HEIGHT
        Else
            PaintPicture imgDigits(m_Style).Picture, X + Count * DIGIT_WIDTH, Y, DIGIT_WIDTH, DIGIT_HEIGHT, 0, (11 - (Number Mod 10)) * DIGIT_HEIGHT, DIGIT_WIDTH, DIGIT_HEIGHT
        End If
        Number = Number \ 10
    Loop
End Sub

Private Sub Form_Load()
    Randomize
    m_Style = 0
    NewGame 9, 9, 10
End Sub

Private Sub SetWindowRect(ByVal NewWidth As Integer, ByVal NewHeight As Integer)
    ' Who can give a better solution?
    Width = ((Width \ Screen.TwipsPerPixelX - ScaleWidth) + NewWidth) * Screen.TwipsPerPixelX
    Height = ((Height \ Screen.TwipsPerPixelY - ScaleHeight) + NewHeight) * Screen.TwipsPerPixelY
End Sub

Private Sub QSort(ByRef List() As SEEDT, ByVal Low As Integer, ByVal High As Integer)
    Dim p As Integer, q As Integer, t As SEEDT
    If Low < High Then
        p = Low: q = High
        Do
            Do Until p = q
                If List(q).Seed < List(p).Seed Then Exit Do
                q = q - 1
            Loop
            t = List(q): List(q) = List(p): List(p) = t
            Do Until p = q
                If List(p).Seed > List(q).Seed Then Exit Do
                p = p + 1
            Loop
            t = List(q): List(q) = List(p): List(p) = t
        Loop Until p = q
        QSort List, Low, p - 1
        QSort List, p + 1, High
    End If
End Sub

Private Function IsValidPosition(ByVal Row As Integer, ByVal Column As Integer) As Boolean
    If Row >= 0 And Row < m_Rows And Column >= 0 And Column < m_Columns Then IsValidPosition = True
End Function

Private Function CountPosition(ByRef Buffer() As Byte, ByVal Row As Integer, ByVal Column As Integer, ByVal Number As Integer) As Integer
    If IsValidPosition(Row, Column) = True Then
        If Buffer(Row, Column) = Number Then CountPosition = 1
    End If
End Function

Private Sub GenerateMap(ByRef Buffer() As Byte, ByVal Rows As Integer, ByVal Columns As Integer, ByVal FirstRow As Integer, ByVal FirstColumn As Integer)
    Dim List() As SEEDT
    Dim Row As Integer, Column As Integer, Index As Integer, Length As Integer, Count As Integer
    If m_Generated = False Then
        Length = Rows * Columns
        ReDim List(Length - 1)
        For Row = 0 To Rows - 1
            For Column = 0 To Columns - 1
                Buffer(Row, Column) = 0
                If Row = FirstRow And Column = FirstColumn Then
                    List(Index).Seed = 1
                Else
                    List(Index).Seed = Rnd()
                End If
                List(Index).Row = Row
                List(Index).Column = Column
                Index = Index + 1
            Next
        Next
        QSort List, 0, Length - 1
        For Index = 0 To m_Mines - 1
            Buffer(List(Index).Row, List(Index).Column) = 5
        Next
        For Row = 0 To Rows - 1
            For Column = 0 To Columns - 1
                If Buffer(Row, Column) = 0 Then
                    Count = CountCircle(Buffer, Row, Column, 5)
                    Buffer(Row, Column) = 15 - Count
                End If
            Next
        Next
        m_Generated = True
    End If
End Sub

Private Sub NewGame(ByVal Rows As Integer, ByVal Columns As Integer, ByVal Mines As Integer)
    If Rows < MIN_ROWS Then
        Rows = MIN_ROWS
    ElseIf Rows > MAX_ROWS Then
        Rows = MAX_ROWS
    End If
    If Columns < MIN_COLUMNS Then
        Columns = MIN_COLUMNS
    ElseIf Columns > MAX_COLUMNS Then
        Columns = MAX_COLUMNS