puzzle.frm

迷宫游戏

VERSION 5.00
Begin VB.Form frmPuzzle 
   BackColor       =   &H00C0FFFF&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Puzzle"
   ClientHeight    =   5040
   ClientLeft      =   1350
   ClientTop       =   1875
   ClientWidth     =   4170
   ClipControls    =   0   'False
   Icon            =   "PUZZLE.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   336
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   278
   StartUpPosition =   2  'CenterScreen
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   1440
      Top             =   2400
   End
   Begin VB.CommandButton cmdButton 
      Caption         =   "cmdButton"
      Height          =   855
      Index           =   0
      Left            =   1200
      TabIndex        =   3
      Top             =   840
      Width           =   975
      Visible         =   0   'False
   End
   Begin VB.ComboBox cmbSize 
      Height          =   315
      ItemData        =   "PUZZLE.frx":030A
      Left            =   720
      List            =   "PUZZLE.frx":030C
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   4440
      Width           =   975
   End
   Begin VB.CommandButton cmdShuffle 
      Caption         =   "Shuffle"
      Height          =   615
      Left            =   2280
      TabIndex        =   0
      Top             =   4200
      Width           =   1215
   End
   Begin VB.Label lblSize 
      BackColor       =   &H00C0FFFF&
      Caption         =   "Size:"
      Height          =   255
      Left            =   720
      TabIndex        =   2
      Top             =   4200
      Width           =   495
   End
   Begin VB.Menu mnuGame 
      Caption         =   "&Game"
      Begin VB.Menu mnuAbout 
         Caption         =   "&About"
      End
      Begin VB.Menu mnuHighScore 
         Caption         =   "&High-Score"
      End
      Begin VB.Menu mnuSound 
         Caption         =   "&Sound"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuExit 
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "frmPuzzle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'-------------------------------------------------------------------------
'Author:    Anders Fransson
'Email:     [e-mail]
'Internet:  http://hem1.passagen.se/fylke
'Date:      97-07-30
'-------------------------------------------------------------------------

Option Explicit

Private mbPuzzleSolved As Boolean
Private miEmptyIndex As Integer
Private miSize As Integer
Private mlTime As Long

Private Const MIN_SIZE As Byte = 3
Private Const MAX_SIZE As Byte = 7

'Text constants
Private Const TEXT_SHUFFLE As String = "Shuffle"
Private Const TEXT_NEW_GAME As String = "New Game"
Private Const TEXT_PUZZLE As String = "Puzzle"
Private Const TEXT_TIME As String = "Time:"
Private Const TEXT_HIGH_SCORE As String = "High score"
Private Const TEXT_SIZE As String = "Size"
Private Const TEXT_TIME_S As String = "Time"
Private Const TEXT_PLAYER As String = "Player"
Private Const TEXT_INPUT_PLAYER As String = "Write your name!"
Private Const TEXT_ANDERS_GAMES As String = "Anders Franssons Made In Home Games"

Private Static Sub Form_Load()

    Dim i%
    
    'Initialize random number generator
    Randomize
   
    'Load buttons
    For i = 1 To MAX_SIZE ^ 2 - 1
        Load cmdButton(i)
    Next
    
    'Add combo box items
    For i = MIN_SIZE To MAX_SIZE
        cmbSize.AddItem i
    Next
    
    'Auto click in combo
    cmbSize.ListIndex = 1
    miSize = cmbSize.Text

End Sub

Private Static Sub Form_Resize()
    
    Dim bTimerWasOn As Boolean

    cmdShuffle.SetFocus

    'Stop timer when game is minimized and start it when normalized
    If Me.WindowState = vbMinimized Then
        If Timer1.Enabled Then bTimerWasOn = True Else bTimerWasOn = False
        Timer1.Enabled = False
    Else
        If bTimerWasOn Then Timer1.Enabled = True
    End If

End Sub

Private Static Sub cmdButton_MouseDown(Index As Integer, Button As Integer, _
                                Shift As Integer, X As Single, Y As Single)
    
    Dim i%, xEmpty%, yEmpty%, xClicked%, yClicked%
    
    'Calculate coordinates for buttons
    xEmpty = (miEmptyIndex) Mod miSize
    yEmpty = (miEmptyIndex) \ miSize
    xClicked = (Index) Mod miSize
    yClicked = (Index) \ miSize
    
    'Change buttons if empty is near
    If (xClicked = xEmpty + 1 And yClicked = yEmpty) Or _
        (xClicked = xEmpty - 1 And yClicked = yEmpty) Or _
        (yClicked = yEmpty + 1 And xClicked = xEmpty) Or _
        (yClicked = yEmpty - 1 And xClicked = xEmpty) Then
            ChangeButtons (Index)
            If mnuSound.Checked Then PlaySound App.Path & "\Move.wav"
    End If

    'Check if puzzle's solved
    For i = 0 To miSize ^ 2 - 2
        If Val(cmdButton(i).Caption) = i + 1 Then
            mbPuzzleSolved = True
        Else
            mbPuzzleSolved = False
            Exit For
        End If
    Next i
    
    If mbPuzzleSolved Then
        If (Timer1.Enabled And mnuSound.Checked) Then PlaySound App.Path & "\Applause.wav"
        Timer1.Enabled = False
        WriteHighScore
        mlTime = 0
        cmdShuffle.Caption = TEXT_SHUFFLE
        cmdShuffle.SetFocus
    Else
        cmdShuffle.Caption = TEXT_NEW_GAME
    End If

End Sub

Private Sub cmdShuffle_Click()

    If mbPuzzleSolved Then
        Shuffle
    Else
        NewGame
    End If

    If mnuSound.Checked Then PlaySound App.Path & "\Shuffle.wav"
    
End Sub

Private Sub cmbSize_Click()
    
    If Not (miSize = cmbSize.Text) Then
        miSize = cmbSize.Text
        NewGame
    End If

End Sub

Private Sub mnuAbout_Click()
    
    frmAbout.ShowAboutForm TEXT_PUZZLE, Me.Icon

End Sub

Private Sub mnuExit_Click()

    Unload Me

End Sub

Private Static Sub mnuHighScore_Click()

    Dim strHighScore As String
    Dim i%
    
    strHighScore = TEXT_SIZE & vbTab & TEXT_TIME_S & vbTab & TEXT_PLAYER & vbNewLine
    
    'Get high score from registry
    For i = MIN_SIZE To MAX_SIZE
        strHighScore = strHighScore & i & vbTab & _
            GetSetting(TEXT_ANDERS_GAMES, TEXT_PUZZLE, i, "-") & vbTab & _
            GetSetting(TEXT_ANDERS_GAMES, TEXT_PUZZLE, TEXT_PLAYER & i, "-") & vbNewLine
    Next

    'Show high score in msgbox
    MsgBox strHighScore, vbOKOnly, TEXT_HIGH_SCORE

End Sub

Private Sub mnuSound_Click()

    mnuSound.Checked = Not mnuSound.Checked

End Sub

Private Sub Timer1_Timer()

    mlTime = mlTime + 1
    Me.Caption = TEXT_TIME & " " & mlTime & " s"

End Sub

Private Static Sub NewGame()
    
    Dim i%, j%, iSide%
    
    Me.Caption = TEXT_PUZZLE
    mlTime = 0
    Timer1.Enabled = False
    mbPuzzleSolved = True
    iSide = Int((90 / miSize)) * 2 + 10
    
    'Hide butons and set caption
    For i = 0 To MAX_SIZE ^ 2 - 1
        cmdButton(i).Visible = False
        cmdButton(i).Caption = i + 1
    Next i
    
    'Place buttons
    For i = 0 To miSize - 1
        For j = 0 To miSize - 1
            cmdButton(i * miSize + j).Height = iSide
            cmdButton(i * miSize + j).Width = iSide
            cmdButton(i * miSize + j).Left = iSide / 2 + iSide * j
            cmdButton(i * miSize + j).Top = iSide / 2 + iSide * i
            cmdButton(i * miSize + j).Visible = True
        Next j
    Next i
    
    miEmptyIndex = miSize ^ 2 - 1
    cmdButton(miEmptyIndex).Visible = False
    cmdShuffle.Caption = TEXT_SHUFFLE

End Sub

Private Static Sub Shuffle()

    Dim bMove As Boolean
    Dim i%, xCoord%, yCoord%, iRand%
    
    'Hide buttons before shuffle
    For i = 0 To miSize ^ 2 - 1
        cmdButton(i).Visible = False
    Next i
    
    'Coordinates for empty button
    xCoord = (miEmptyIndex) Mod miSize
    yCoord = (miEmptyIndex) \ miSize
    
    'Move buttons in random directions
    i = 0
    While i < miSize ^ 4
        bMove = False
        iRand = Int(4 * Rnd)
        If (iRand = 0) And (xCoord > 0) Then
            xCoord = xCoord - 1
            bMove = True
        ElseIf (iRand = 1) And (xCoord < miSize - 1) Then
            xCoord = xCoord + 1
            bMove = True
        ElseIf (iRand = 2) And (yCoord > 0) Then
            yCoord = yCoord - 1
            bMove = True
        ElseIf (iRand = 3) And (yCoord < miSize - 1) Then
            yCoord = yCoord + 1
            bMove = True
        End If
        If bMove Then
            cmdButton(miEmptyIndex).Caption = _
                cmdButton(miSize * yCoord + xCoord).Caption
            miEmptyIndex = miSize * yCoord + xCoord
            i = i + 1
        End If
    Wend
       
    For i = 0 To miSize ^ 2 - 1
        cmdButton(i).Visible = True
    Next i
    
    cmdShuffle.Caption = TEXT_NEW_GAME
    cmdButton(miEmptyIndex).Visible = False
    mbPuzzleSolved = False
    Timer1.Enabled = True
    
End Sub

Private Sub ChangeButtons(Index As Integer)
    
    'Change caption and visibility of clicked and empty button
    cmdButton(miEmptyIndex).Caption = cmdButton(Index).Caption
    cmdButton(miEmptyIndex).Visible = True
    cmdButton(miEmptyIndex).SetFocus
    miEmptyIndex = Index
    cmdButton(Index).Visible = False
    cmdButton(Index).Caption = ""

End Sub

Private Sub WriteHighScore()
     
    'Write high score to registry
    If mlTime > 0 And mlTime < GetSetting(TEXT_ANDERS_GAMES, TEXT_PUZZLE, miSize, 9999) Then
        SaveSetting TEXT_ANDERS_GAMES, TEXT_PUZZLE, miSize, mlTime
        SaveSetting TEXT_ANDERS_GAMES, TEXT_PUZZLE, TEXT_PLAYER & miSize, _
            Left(Trim(InputBox(TEXT_INPUT_PLAYER, TEXT_HIGH_SCORE)), 20)
    End If

End Sub