frmmain.frm

VB编写的RPG游戏演示,适合VB游戏初学者的参考。

VERSION 5.00
Begin VB.MDIForm frmMain 
   BackColor       =   &H8000000C&
   Caption         =   "Map Editor"
   ClientHeight    =   5685
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   7290
   LinkTopic       =   "MDIForm1"
   ScrollBars      =   0   'False
   StartUpPosition =   3  'Windows Default
   WindowState     =   2  'Maximized
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileNew 
         Caption         =   "&New"
      End
      Begin VB.Menu mnuFileOpen 
         Caption         =   "&Open"
      End
      Begin VB.Menu mnuFileSave 
         Caption         =   "&Save"
      End
      Begin VB.Menu mnuFileSaveAs 
         Caption         =   "Save &As"
      End
      Begin VB.Menu mnuFileClose 
         Caption         =   "&Close"
      End
      Begin VB.Menu mnuSeperator 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' KNOWN ISSUES:
'
' - using the ALT keys to access the menu DOES NOT
'   trigger the "Lost_Focus" events of the text boxes
'   and any entered data will be ignored in the save!
'

Private Sub MDIForm_Load()

    'Load the tileset
    ExtractTilesetData App.Path & "\..\tileset.bmp"
    
End Sub

Private Sub MDIForm_Unload(Cancel As Integer)

    'Check for dirtiness before exiting
    Cancel = ExitProgram()
    
End Sub

Private Sub mnuFileClose_Click()

Dim intRetVal As Integer

    'Check for dirtiness..
    If gblnDirty Then
        intRetVal = MsgBox("Map data has changed since last save. Save now?", vbYesNoCancel, "Save before closing?")
        If intRetVal = vbYes Then
            mnuFileSave_Click
            Exit Sub
        ElseIf intRetVal = vbCancel Then
            Exit Sub
        End If
    End If

    'Close the forms
    UnloadForms

    'Erase the name
    gstrMapName = ""

End Sub

Private Sub mnuFileExit_Click()

    'End the program
    Unload Me

End Sub

Private Sub mnuFileNew_Click()

    'Handle errors
    On Local Error GoTo ErrOut
    
    'Check for dirtiness first...
    If gblnDirty Then
        intRetVal = MsgBox("Map data has changed since last save. Save now?", vbYesNoCancel, "Save before closing?")
        If intRetVal = vbYes Then
            frmMain.mnuFileSave_Click
        ElseIf intRetVal = vbCancel Then
            Exit Sub
        End If
    End If
    gblnDirty = False
    
    'Close the forms
    UnloadForms

    'Set a map size
    gintMapWidth = InputBox("Map width:", "Map Width")
    gintMapHeight = InputBox("Map height:", "Map Height")
    If gintMapWidth < 20 Then gintMapWidth = 20
    If gintMapHeight < 15 Then gintMapHeight = 15
    ReDim gudtMap(gintMapWidth, gintMapHeight)
    ReDim gudtNPC(0)
    ReDim gudtNPC(0).udtBehaviour(0)
    
    'Load the forms
    LoadForms
    
    'Set the map as "dirty"
    gblnDirty = True
    
    'Exit before error code
    Exit Sub
    
ErrOut:
    MsgBox "Invalid input.", vbOKOnly, "Error"

End Sub

Private Sub mnuFileOpen_Click()

Dim strTemp As String
Dim intRetVal As Integer
Dim intNPCNum As Integer

    'Handle errors
    On Error GoTo ErrOut

    'Get the filename
    strTemp = InputBox("Enter filename:", "Open")
    If Dir(App.Path & "\" & strTemp) = "" Then
        MsgBox "No such file.", vbOKOnly, "Error"
        Exit Sub
    End If
    
    'Check for dirtiness first...
    If gblnDirty Then
        intRetVal = MsgBox("Map data has changed since last save. Save now?", vbYesNoCancel, "Save before closing?")
        If intRetVal = vbYes Then
            frmMain.mnuFileSave_Click
        ElseIf intRetVal = vbCancel Then
            Exit Sub
        End If
    End If
    gblnDirty = False
    
    'Close the forms
    UnloadForms
    
    'Set the map name
    gstrMapName = strTemp
    
    'Open it
    Open App.Path & "\" & gstrMapName For Binary Access Read Lock Write As #1
        'Get the map data
        Get #1, 1, gintMapWidth
        Get #1, , gintMapHeight
        ReDim gudtMap(gintMapWidth, gintMapHeight)
        Get #1, , gudtMap
        'Get the NPC data
        Get #1, , intNPCNum
        ReDim gudtNPC(intNPCNum)
        Get #1, , gudtNPC
        'Get the title/music
        Get #1, , gstrMapName
        Get #1, , gstrMusic
    Close #1
    
    'Load the forms
    LoadForms
    
    'Set it as "clean"
    gblnDirty = False
    
    'Exit before error code
    Exit Sub
    
ErrOut:
    MsgBox "Invalid input.", vbOKOnly, "Error"
    
End Sub

Public Sub mnuFileSave_Click()

    'If it hasn't been saved before..
    If gstrMapName = "" Then
        mnuFileSaveAs_Click
        Exit Sub
    End If
    
    'Save
    SaveMap gstrMapName

End Sub

Private Sub mnuFileSaveAs_Click()

Dim intRetVal As Integer
Dim strTemp As String

    'Handle errors
    On Error GoTo ErrOut

    'Get the filename
    strTemp = InputBox("Enter filename:", "Save")
    If Dir(App.Path & "\" & strTemp) <> "" Then
        intRetVal = MsgBox("File already exists. Overwrite?", vbYesNo)
        If intRetVal = vbNo Then Exit Sub
    End If
    
    'Save
    SaveMap strTemp
    
    'Exit before error code
    Exit Sub
    
ErrOut:
    MsgBox "Invalid input.", vbOKOnly, "Error"

End Sub

Private Sub SaveMap(strTemp As String)

Dim intNPCNum As Integer

    'Store the data
    Open App.Path & "\" & strTemp For Binary Access Write Lock Write As #1
        'Store the map info
        Put #1, 1, gintMapWidth
        Put #1, , gintMapHeight
        Put #1, , gudtMap
        'Store the NPC info
        intNPCNum = UBound(gudtNPC)
        Put #1, , intNPCNum
        Put #1, , gudtNPC
        'Store the title/music
        Put #1, , gstrMapName
        Put #1, , gstrMusic
    Close #1

    'Set the map name
    gstrMapName = strTemp

    'Set the map as "clean"
    gblnDirty = False

End Sub