mvaders.bas

八脚蟹》射击游戏源码

'Return success
iInitLevel = iRetVal

End Function

Function iLoadScenario(ByVal sFName As String) As Integer
'==AutoDoc==
'Purpose    Load all level data from disk file and store
'           in global arrays
'Entry      sFName - name of data file to load, must reside
'                    in same directory as executable
'Exit       True if file loaded ok

Dim iFNum As Integer
Dim iLevels As Integer
Dim iOpen As Integer
Dim iSprites As Integer
Dim iSpriteCount As Integer
Dim iThisLevel As Integer
Dim iThisSprite As Integer
Dim iRetVal As Integer
Dim iTmp As Integer
Dim sTmp As String

'We are accessing disk files, trap errors
On Error GoTo LoadScenario_ERR

'Default to true
iRetVal = True

'Make sure we look in games directory
sFName = App.Path & "/" & sFName

'Open the file
iFNum = FreeFile
Open sFName For Input As #iFNum
iOpen = True

'Read verion details
Input #iFNum, sTmp

'Check version details
If sTmp <> "MVaders Game File" Then
    MsgBox "MVaders Error, invalid game file header", , "MVaders"
    Close #iFNum
    Exit Function
End If

'Read number of levels
Input #iFNum, iLevels

'Redimension Game array
ReDim gtLevel(iLevels)

'Store in global variable
giNumLevels = iLevels

'Read total number of sprites in the file
Input #iFNum, iTmp

'Redimension Level array
ReDim gtInvader(iTmp)

'Parse the file
iSpriteCount = 0
For iThisLevel = 1 To iLevels
    
    'Read number of sprites in this level
    Input #iFNum, iSprites
    
    'Store 1st and last indecies for this level
    gtLevel(iThisLevel).iFirst = iSpriteCount + 1
    gtLevel(iThisLevel).iLast = iSpriteCount + iSprites
    
    'Read all sprite data for this level
    For iThisSprite = 1 To iSprites
        
        'Bump counter
        iSpriteCount = iSpriteCount + 1

        'Read sprite definition
        Input #iFNum, gtInvader(iSpriteCount).iId, gtInvader(iSpriteCount).iX, gtInvader(iSpriteCount).iY, gtInvader(iSpriteCount).iHits, gtInvader(iSpriteCount).iTx, gtInvader(iSpriteCount).iPowerUp
    
    Next iThisSprite

Next iThisLevel

'Close the file
Close #iFNum

'Return success
iLoadScenario = iRetVal
Exit Function

LoadScenario_ERR:
'Report error and return failure
MsgBox "The following error occurred:" & Chr$(10) & Error$(Err), , "MVaders"
If iOpen Then Close #iFNum
iLoadScenario = False
Exit Function

End Function

Sub LoadFame()
'==AutoDoc==
'Purpose    Load high scores from disk file
'Entry      None
'Exit       None
'Comments

Dim i As Integer
Dim iFNum As Integer
Dim sFName As String

'Accessing disk files, trap errors
On Error GoTo LoadFame_Err

'Build file name
sFName = App.Path & "/Scores.dat"

'Open the file
iFNum = FreeFile
Open sFName For Input As #iFNum

'Read previous scores
For i = 1 To 10
    Input #iFNum, gtFame(i).iScore, gtFame(i).sName
Next i

'Set highest score
giHighScore = gtFame(1).iScore
gsWho = gtFame(1).sName

'Close the file
Close #iFNum

Exit Sub
LoadFame_Err:
'There was an error, default the scores;)
For i = 1 To 10
    gtFame(i).sName = "Mr. Nobody"
    gtFame(i).iScore = 55 - 5 * i
Next i
'Set highest score
giHighScore = gtFame(1).iScore
gsWho = gtFame(1).sName

Exit Sub
End Sub

Sub LoadPrefs()
'==AutoDoc==

Dim sFName As String
Dim iFNum As Integer

'Trap error if file not accessible
On Error GoTo LoadPrefs_Err

'Name of ini file
sFName = App.Path & "\Prefs.dat"
iFNum = FreeFile

'Open the file
Open sFName For Input As #iFNum

'Read data from the file
Input #iFNum, GamePrefs.iTimer, GamePrefs.iIGap, GamePrefs.iISpeed, GamePrefs.iIBSpeed, GamePrefs.fIBFreq, GamePrefs.iIDrop, GamePrefs.iPSpeed, GamePrefs.iPBSpeed

'Close the file
Close #iFNum

Exit Sub
LoadPrefs_Err:

'Default game preferences
GamePrefs.iTimer = 50
GamePrefs.iIGap = 50
GamePrefs.iISpeed = 4
GamePrefs.iIBSpeed = 12
GamePrefs.fIBFreq = 0.9
GamePrefs.iIDrop = 20
GamePrefs.iPSpeed = 10
GamePrefs.iPBSpeed = 17

Exit Sub
End Sub

Sub Main()
'==AutoDoc==
'Purpose    The game start-up code
'Entry      None
'Exit       None
'Comments   Initialises everything, loads data files etc.
'           If an error occurs then appropriate message is
'           displayed.

Dim i As Integer

Randomize

'Load the high scores, now is as good a time as any;)
LoadFame

'Load game preferences
LoadPrefs

'Hard code sprites available
gInitSprites

'Must initialise the array used by Sprite Engine
ReDim gtSpr(MAX_SPRITES_USED)

'Load the game form
Load frmMVaders

'Get play area
i = iSprGetPlayDC(frmMVaders.hdc, GAME_WIDTH, GAME_HEIGHT)

'Load sprite graphics
If i Then
    i = iSprLoadGfx(frmMVaders.picSpr, "MVaders.bmp")

    'Load sprite graphic frame data
    If i Then
        i = iSprLoadFrames("frames.dat")

        'Load the game scenario
        If i Then
            i = iLoadScenario("scene01.mm2")

            'Let play commence!
            If i Then
                frmMVaders.Show vbModal
            Else
                FatalError "Failed to load game scenario data file"
            End If
        Else
            FatalError "Failed to load sprite frame-data file"
        End If
    Else
        FatalError "Failed to load sprite graphics file"
    End If
Else
    FatalError "Failed to allocate off screen buffer"
End If

'Make sure all resources are released
SprFreeAll

'Trash the form
Unload frmMVaders

End Sub

Sub PlayHitMe()
'==AutoDoc==
'Purpose    To play a random sound when an invader gets
'           killed
'Entry      None
'Exit       None
'Comments   Well, gotta make it fun;)

Dim i As Integer
Dim l As Long
Dim sFName As String

i = Int(Rnd * 10) + 1
sFName = App.Path & "\dead" & Format$(i, "") & ".wav"
l = sndPlaySound(ByVal CStr(sFName), SND_ASYNC)

End Sub

Sub PlaySound(ByVal vsFName As String)
'==AutoDoc==
'Purpose    Play a .wav sound file
'Entry      vsFName - name of the wav file to play
'Exit       None
'Comments   One of Marks routines!


Dim l As Long

'Call API function to play the sound
l = sndPlaySound(ByVal CStr(vsFName), SND_ASYNC)

End Sub

Sub SaveFame()
'==AutoDoc==
'Purpose    Save high scores to disk
'Entry      None
'Exit       None
'Comments

Dim i As Integer
Dim iFNum As Integer
Dim sFName As String

'Accessing disk files, trap errors
On Error GoTo SaveFame_Err

'Build file name
sFName = App.Path & "/Scores.dat"

'Open the file
iFNum = FreeFile
Open sFName For Output As #iFNum

'Read previous scores
For i = 1 To 10
    Write #iFNum, gtFame(i).iScore, gtFame(i).sName
Next i

'Close the file
Close #iFNum

Exit Sub
SaveFame_Err:
'There was an error, inform user
MsgBox "Unable to save 'Hall of Fame' to:" & Chr$(10) & sFName
Exit Sub
End Sub

Sub SavePrefs()
'==AutoDoc==

Dim sFName As String
Dim iFNum As Integer

'Trap error if file not accessible
On Error GoTo SavePrefs_Err

'Name of file
sFName = App.Path & "\Prefs.dat"
iFNum = FreeFile

'Open the file
Open sFName For Output As #iFNum

'Write data to the file
Write #iFNum, GamePrefs.iTimer, GamePrefs.iIGap, GamePrefs.iISpeed, GamePrefs.iIBSpeed, GamePrefs.fIBFreq, GamePrefs.iIDrop, GamePrefs.iPSpeed, GamePrefs.iPBSpeed

'Close the file
Close #iFNum

Exit Sub
SavePrefs_Err:

Exit Sub
End Sub

Sub ScanDir(lstList As ListBox)
'==AutoDoc==
'Purpose    Populate a given listbox with the names of all
'           files in a given directory.
'Entry      lstList - the list box to populate
'Exit       None, but contents of list box will have been
'           modified.
'Comments   One of Marks routines!

Dim sNextEntry As String
Dim sPath As String
Dim iLen As Integer
Dim iAttr As Integer

'Constants for use with GetAttr():
Const ATTR_NORMAL = 0       'Normal file
Const ATTR_READONLY = 1     'Read-only file
Const ATTR_HIDDEN = 2       'Hidden file
Const ATTR_SYSTEM = 4       'System file
Const ATTR_VOLUME = 8       'Volume label
Const ATTR_DIRECTORY = 16   'MS-DOS directory
Const ATTR_ARCHIVE = 32     'File has changed since last back-up

'Look in executables directory
sPath = App.Path & "\*.mm2"

'Define types of files etc to search for
iAttr = ATTR_NORMAL + ATTR_READONLY

'Make sure path is terminated with a \ character
iLen = Len(sPath)
'If iLen > 0 And Mid$(sPath, iLen, 1) <> "\" Then sPath = sPath & "\"

'Get first entry in directory, initialises Dir()
sNextEntry = Dir(sPath, iAttr)

'Now fetch all other entries
While Len(sNextEntry)

    'Only include 'reasonable' filenames
    If sNextEntry <> "." And sNextEntry <> ".." Then
        lstList.AddItem sNextEntry
    End If

    'Fetch next filename
    sNextEntry = Dir
Wend

End Sub

Sub ShowScores(picTmp As PictureBox)
'==AutoDoc==
'Purpose    Display the hall of fame on the Play area.
'Entry      picTmp - PictureBox to use for building the
'                    text.
'Exit
'Comments   This is crude and could be improved!!

Dim i As Integer
Dim iX As Integer
Dim iY As Integer
Dim iSMode As Integer
Dim iW As Integer
Dim iH As Integer
Dim iAt As Integer
Dim sTmp As String * 40

'Determine size of the scores
sTmp = "1234567890123456789012345678901234567890"
iW = frmMVaders.TextWidth(sTmp)
iH = 10 * frmMVaders.TextHeight(sTmp)
iX = (frmMVaders.ScaleWidth - iW) \ 2
iY = (frmMVaders.ScaleHeight - iH) \ 2

'Display the scores
frmMVaders.CurrentY = iY
For i = 1 To 10
    sTmp = Format$(i, "@@") & " " & Format$(gtFame(i).iScore, "0000") & "0 " & gtFame(i).sName
    frmMVaders.CurrentX = iX
    frmMVaders.Print sTmp
Next i

'Now splat the text into the Play DC
'i = BitBlt(frmMVaders.hDC, iX, iY, iW, iH, picTmp.hDC, iW, iH, SRCCOPY)

End Sub