frmeditor.frm

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

VERSION 5.00
Begin VB.Form frmEditor 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "仓库世家 关卡设计器"
   ClientHeight    =   7200
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   11520
   Icon            =   "frmEditor.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   480
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   768
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox picMain 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      Height          =   7200
      Left            =   0
      ScaleHeight     =   480
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   640
      TabIndex        =   6
      Top             =   0
      Width           =   9600
      Begin VB.Image imgBaby 
         Height          =   480
         Left            =   0
         Picture         =   "frmEditor.frx":6852
         Top             =   0
         Width           =   480
      End
   End
   Begin VB.Frame fraInfo 
      Caption         =   "地图信息"
      Height          =   1305
      Left            =   9630
      TabIndex        =   3
      Top             =   150
      Width           =   1830
      Begin VB.PictureBox picBox 
         BorderStyle     =   0  'None
         Height          =   480
         Left            =   675
         Picture         =   "frmEditor.frx":6E46
         ScaleHeight     =   480
         ScaleWidth      =   480
         TabIndex        =   5
         Top             =   300
         Width           =   480
      End
      Begin VB.Label lblInfo 
         Alignment       =   2  'Center
         Caption         =   "第几关"
         Height          =   180
         Left            =   90
         TabIndex        =   4
         Top             =   930
         Width           =   1710
      End
   End
   Begin VB.Frame fraHelp 
      Caption         =   "使用帮助"
      Height          =   5520
      Left            =   9630
      TabIndex        =   1
      Top             =   1620
      Width           =   1830
      Begin VB.Label lblHelp 
         Caption         =   "使用帮助"
         Height          =   5055
         Left            =   150
         TabIndex        =   2
         Top             =   300
         Width           =   1515
      End
   End
   Begin VB.PictureBox picBoxs 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   480
      Left            =   0
      Picture         =   "frmEditor.frx":7A8A
      ScaleHeight     =   480
      ScaleWidth      =   2400
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   2400
   End
End
Attribute VB_Name = "frmEditor"
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 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 X As Integer, Y As Integer
Private ScenesCount As Integer, CurrScene As Integer
Private FileNum As Integer
Private CurrBox     As Integer ' 当前使用的地图块
Private Changed     As Boolean ' 地图是否改变，如果是，在切换和退出时提示保存


' 初始化
Private Sub Form_Load()
    
    lblHelp.Caption = _
        "方向键 - 移动" & vbCrLf & _
        "   空格 - 选图" & vbCrLf & _
        "   Ctrl - 绘图" & vbCrLf & _
        "      N - 新地图" & vbCrLf & _
        "   PgUp - 上一关" & vbCrLf & _
        "PgDown - 下一关" & vbCrLf & _
        "      S - 保存" & vbCrLf & _
        "    Esc - 退出" & vbCrLf & _
        vbCrLf & _
        "其它说明：" & vbCrLf & _
        "    一、任何未保存的操作都会有提示；" & vbCrLf & _
        "    二、企鹅最后停留的位置为本关的起始位置。"
    
    FileNum = FreeFile
    Open "Map.dat" For Binary As FileNum
    ScenesCount = LOF(FileNum) / 302
    
    NewMap

End Sub

' 保存地图
Private Sub SaveMap()
    
    If CurrScene > ScenesCount Then ScenesCount = CurrScene
    
    Put FileNum, (CurrScene - 1) * 302 + 1, CByte(X)
    Put FileNum, , CByte(Y)
    
    Dim i As Long, j As Long
    For i = 0 To 14
        For j = 0 To 19
            Put FileNum, , CByte(Map(j, i))
        Next
    Next
    
    Changed = False

End Sub

' 读取地图
Private Sub LoadMap(Offset As Integer)
    
    If CurrScene + Offset > ScenesCount Then
        NewMap
        Exit Sub
    End If
    If CurrScene + Offset < 1 Then
        Exit Sub
    End If
    If Not AskSave Then Exit Sub
    
    CurrScene = CurrScene + Offset
    lblInfo.Caption = "第" & CurrScene & "关"
    
    
    Dim Data As Byte
  
    Get FileNum, (CurrScene - 1) * 302 + 1, Data
    X = Data
    Get FileNum, , Data
    Y = Data
    
    Dim i As Long, j As Long
    For i = 0 To 14
        For j = 0 To 19
            Get FileNum, , Data
            Map(j, i) = Data
        Next
    Next
    
    DrawMap
    
    Changed = False

End Sub

' 新地图
Private Sub NewMap()
    
    If Not AskSave Then Exit Sub

    Dim i As Long, j As Long
    For i = 0 To 14
        For j = 0 To 19
            Map(j, i) = B_BACK
        Next
    Next
    
    CurrScene = ScenesCount + 1
    lblInfo.Caption = "第" & CurrScene & "关"
    X = 0: Y = 0
    Changed = False
    
    DrawMap

End Sub


' 按键处理
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    
   
    Select Case KeyCode
        Case 37 ' 改变坐标
            X = (X + 20 - 1) Mod 20
        Case 38
            Y = (Y + 15 - 1) Mod 15
        Case 39
            X = (X + 1) Mod 20
        Case 40
            Y = (Y + 1) Mod 15
        
        Case 32 ' 空格：绘制地图块，并且当前使用地图块轮换
        
            Select Case CurrBox
                Case B_BACK
                    Map(X, Y) = B_GROUND
                Case B_GROUND
                    Map(X, Y) = B_DEST
                Case B_DEST
                    Map(X, Y) = B_BOX
                Case B_BOX
                    Map(X, Y) = B_WALL
                Case B_WALL
                    Map(X, Y) = B_BACK
            End Select
            Changed = True
            CurrBox = Map(X, Y)
            BitBlt picBox.hDC, 0, 0, 32, 32, picBoxs.hDC, DrawBox(X, Y, CurrBox) * 32, 0, vbSrcCopy
            picMain.Refresh
        
        Case Asc("N")
            NewMap
        Case 33
            LoadMap (-1)
        Case 34
            LoadMap (1)
        Case Asc("S")
            SaveMap
        Case 27
            Unload Me
    End Select
    
    imgBaby.Move X * 32, Y * 32
    ' 要注意的是，本程序中，小人不是用API绘制的，而是直接采用一个PictureBox控件，
    ' 小人移动只需改变控件的坐标即成。
    
    If Shift = vbCtrlMask Then ' Ctrl键绘制
        Map(X, Y) = CurrBox
        Changed = True
        DrawBox X, Y, CurrBox
        picMain.Refresh
    End If

End Sub

' 绘制地图块
Private Function DrawBox(ByVal X As Integer, ByVal Y As Integer, ByVal BoxType As Integer) 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
    DrawBox = Offset
End Function

' 确认退出
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If Not AskSave Then
        Cancel = 1
    Else
        Close FileNum
        End
    End If
End Sub

' 保存提示（Changed为真，又进行关卡切换、退出时发生）
Private Function AskSave() As Boolean
    If Not Changed Then
        AskSave = True
        Exit Function
    End If
    Dim Temp As Integer
    Temp = MsgBox("要保存更改吗？", vbQuestion Or vbYesNoCancel, "提示")
    Select Case Temp
        Case vbYes
            SaveMap
            AskSave = True
        Case vbNo
            AskSave = True
        Case vbCancel
            AskSave = False
    End Select
End Function

' 整个画面刷新
Private Sub DrawMap()
    
    Dim i As Long, j As Long
    For i = 0 To 14
        For j = 0 To 19
            DrawBox j, i, Map(j, i)
        Next
    Next
    picMain.Refresh

End Sub