frmmain.frm

用到了Picture控件来制作的推箱子游戏

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "推箱子"
   ClientHeight    =   7500
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9600
   Icon            =   "frmMain.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   7500
   ScaleWidth      =   9600
   StartUpPosition =   2  '屏幕中心
   Begin MSComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   300
      Left            =   0
      TabIndex        =   3
      Top             =   7200
      Width           =   9600
      _ExtentX        =   16933
      _ExtentY        =   529
      Style           =   1
      SimpleText      =   "方向键 - 移动 | 空格 - 重新开始 | 回车 - 选择一关 | Page Up - 上一关 | Page Down - 下一关 | Esc - 退出"
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
   Begin VB.PictureBox picMan 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   960
      Left            =   2520
      Picture         =   "frmMain.frx":6852
      ScaleHeight     =   960
      ScaleWidth      =   1920
      TabIndex        =   2
      Top             =   3000
      Visible         =   0   'False
      Width           =   1920
   End
   Begin VB.PictureBox picBoxs 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   480
      Left            =   4800
      Picture         =   "frmMain.frx":C896
      ScaleHeight     =   480
      ScaleWidth      =   2400
      TabIndex        =   1
      Top             =   3240
      Visible         =   0   'False
      Width           =   2400
   End
   Begin VB.PictureBox picMain 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      Height          =   7200
      Left            =   0
      ScaleHeight     =   480
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   640
      TabIndex        =   0
      Top             =   0
      Width           =   9600
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' API函数声明
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, _
    ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
    ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

' 全局常量
Private Const MAXX  As Integer = 20
Private Const MAXY  As Integer = 15
Private Const SIZE  As Integer = 302

Private Const D_LEFT  As Integer = 1
Private Const D_RIGHT As Integer = 0
Private Const D_UP    As Integer = 2
Private Const D_DOWN  As Integer = 3

Private Const B_GROUND    As Integer = &H0
Private Const B_DEST      As Integer = &H1
Private Const B_BOX       As Integer = &H2
Private Const B_WALL      As Integer = &H4
Private Const B_BACK      As Integer = &H8

' 全局变量
Private Map(MAXX, MAXY) As Integer
Private ScenesCount As Integer, CurrScene As Integer
Private BoxCount As Integer, Completed As Integer
Private X As Integer, Y As Integer, Dir As Integer

Private FileNum As Integer
Private MapLoading As Boolean
Private Playing As Boolean

' 游戏开始
Private Sub Form_Load()
    
    Playing = False
    MapLoading = False
    
    InitGame

End Sub

' 游戏初始化
Private Sub InitGame()
    
    FileNum = FreeFile
    Open "Map.dat" For Binary Access Read As FileNum
    
    ScenesCount = LOF(FileNum) / SIZE
    
    If ScenesCount = 0 Then
        MsgBox "没有可用的地图文件或文件格式出错，" & vbCrLf & _
            "请把可用的 Map.dat 文件和游戏放在同一目录。", _
            vbOKOnly Or vbExclamation, "文件读取错误"
        End
    End If
    
    LoadMap 1
    
    Playing = True

End Sub

' 读取关卡数据
Private Function LoadMap(Scene As Integer) As Boolean
    
    If MapLoading Then Exit Function
    
    If Scene < 1 Or Scene > ScenesCount Then
        LoadMap = False
        Exit Function
    End If
    
    MapLoading = True
    
    CurrScene = Scene
    Caption = "推箱子 第" & CurrScene & "关"
    
    BoxCount = 0: Completed = 0
        
    Dir = 0
    
    Dim Data As Byte
    
    Get FileNum, (CurrScene - 1) * SIZE + 1, Data
    X = Data
    Get FileNum, , Data
    Y = Data
    
    Dim i As Long, j As Long
    For i = 0 To MAXY - 1
        For j = 0 To MAXX - 1
            Get FileNum, , Data
            Map(j, i) = Data
            If Map(j, i) And B_DEST Then BoxCount = BoxCount + 1
        Next
    Next
    
    DrawMap
        
    LoadMap = True
    
    MapLoading = False

End Function

' 选择关卡
Private Sub SelectMap()
    Dim Temp As Integer
    Temp = Val(InputBox("请输入关数（1～" & Trim(ScenesCount) & "）", "选择一关", 1))
    If Temp >= 1 And Temp <= ScenesCount Then CurrScene = Temp
    LoadMap Temp
End Sub

' 显示整个游戏画面
Private Sub DrawMap()
        
    Dim i As Long, j As Long
    
    For i = 0 To MAXY - 1
        For j = 0 To MAXX - 1
            DrawBox j, i, Map(j, i)
        Next
    Next
    DrawMan X, Y
    
    picMain.Refresh

End Sub

' 显示背景块（包括地面、墙、箱子等）
Private Sub DrawBox(ByVal X As Integer, ByVal Y As Integer, ByVal BoxType As Integer)
    Dim Offset As Integer
    Select Case BoxType
        Case B_BACK
            Offset = 0
        Case B_GROUND
            Offset = 1
        Case B_DEST
            Offset = 2
        Case B_BOX
            Offset = 3
        Case B_WALL
            Offset = 4
    End Select
    BitBlt picMain.hDC, X * 32, Y * 32, 32, 32, picBoxs.hDC, Offset * 32, 0, vbSrcCopy
End Sub

' 显示小人
Private Sub DrawMan(ByVal X As Integer, ByVal Y As Integer)
    BitBlt picMain.hDC, X * 32, Y * 32, 32, 32, picMan.hDC, Dir * 32, 32, vbSrcAnd
    BitBlt picMain.hDC, X * 32, Y * 32, 32, 32, picMan.hDC, Dir * 32, 0, vbSrcPaint
End Sub

' 游戏操作（按键处理）
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    If Not Playing Then Exit Sub
    
    Select Case KeyCode
        Case 37
            ManMove -1, 0
        Case 38
            ManMove 0, -1
        Case 39
            ManMove 1, 0
        Case 40
            ManMove 0, 1
        Case 32
            LoadMap CurrScene
        Case 33
            LoadMap CurrScene - 1
        Case 34
            LoadMap CurrScene + 1
        Case 13
            SelectMap
        Case 27
            Unload Me
    End Select
    
End Sub

' 游戏结束
Private Sub Form_Unload(Cancel As Integer)
    Close
    End
End Sub

' 小人移动
Private Sub ManMove(OffsetX As Integer, OffsetY As Integer)
    Dim DestX As Integer, DestY As Integer
    
    If OffsetY = -1 Then
        Dir = D_UP
    ElseIf OffsetY = 1 Then
        Dir = D_DOWN
    ElseIf OffsetX = -1 Then
        Dir = D_LEFT
    Else
        Dir = D_RIGHT
    End If
    
    DestX = X + OffsetX: DestY = Y + OffsetY
    
    If DestX < 0 Or DestX >= MAXX Or DestY < 0 Or DestY >= MAXY Then Exit Sub
    If Map(DestX, DestY) And B_WALL Or Map(DestX, DestY) And B_BACK Then Exit Sub
    
    If Map(DestX, DestY) And B_BOX Then
        Push DestX, DestY, OffsetX, OffsetY
    Else
        
        DrawMan DestX, DestY
        DrawBox X, Y, Map(X, Y)
        X = DestX: Y = DestY
        picMain.Refresh
    
    End If

End Sub

' 推动箱子
Private Sub Push(SourceX As Integer, SourceY As Integer, OffsetX As Integer, OffsetY As Integer)
    Dim DestX As Integer, DestY As Integer
    
    DestX = SourceX + OffsetX: DestY = SourceY + OffsetY
    
    If DestX < 0 Or DestX >= MAXX Or DestY < 0 Or DestY >= MAXY Then Exit Sub
    If Map(DestX, DestY) And B_WALL Or Map(DestX, DestY) And B_BACK Or _
        Map(DestX, DestY) And B_BOX Then Exit Sub
    
    Map(SourceX, SourceY) = Map(SourceX, SourceY) - B_BOX
    Map(DestX, DestY) = Map(DestX, DestY) + B_BOX
    
    DrawBox DestX, DestY, B_BOX
    DrawBox SourceX, SourceY, Map(SourceX, SourceY)
    DrawMan SourceX, SourceY
    DrawBox X, Y, Map(X, Y)
    X = SourceX: Y = SourceY
    picMain.Refresh
    
    If Map(SourceX, SourceY) And B_DEST Then Completed = Completed - 1
    If Map(DestX, DestY) And B_DEST Then Completed = Completed + 1
    If Completed = BoxCount Then Win

End Sub

' 过关处理
Private Sub Win()
    If MsgBox("你太聪明了！要继续玩下一关吗？", vbYesNo, "过关！") = vbNo Then
        Unload Me
    End If
    If Not LoadMap(CurrScene + 1) Then
        If MsgBox("你已经过了最后一关！还要继续吗？", vbYesNo, "真厉害！") = vbYes Then
            LoadMap CurrScene
        Else
            Unload Me
        End If
    End If
End Sub