spreng.bas

八脚蟹》射击游戏源码

Function iSprLoadFrames(ByVal vsFName As String) As Integer
'==AutoDoc==
'Purpose    Load frame details from a file
'Entry      vsFName - name of data file to load
'Exit       True if operation successful
'Comments   The data file must reside in the same
'           directory as the executable.
'           Frame Editor completed Sep 7th '97!

Dim iFNum As Integer
Dim i As Integer
Dim iCount As Integer
Dim lY As Long
Dim lW As Long
Dim lH As Long
Dim iOpen As Integer
Dim iTmp As Integer
Dim sFName As String
Dim sBMPName As String
Dim sTmp As String
Dim tFrame As SprFrame

'Trap errros as we are accessing disk files
On Error GoTo LoadFrames_Err

'Clear the array quickly
ReDim gtSprFrm(0)

'Build full filename
sFName = App.Path & "/" & vsFName

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

'Read verion details
Input #iFNum, sTmp, iTmp

'Check version details
If sTmp <> "MM Frame File" Or iTmp <> 2 Then
    MsgBox "Sprite Engine Error, invalid frame file version number or file header", , "Sprite Engine"
    Close #iFNum
    Exit Function
End If

'Read name of the gfx file, ignored for time being:(
Input #iFNum, sTmp

'Read number of frames
Input #iFNum, iCount

'Redimension array
ReDim gtSprFrm(iCount)

'Read one frame at a time and add to array
For i = 0 To iCount - 1
    Input #iFNum, tFrame.lX, tFrame.lY, tFrame.lW, tFrame.lH
    tFrame.lW = tFrame.lW - tFrame.lX + 1
    tFrame.lH = tFrame.lH - tFrame.lY + 1
    gtSprFrm(i) = tFrame
Next i

'Close the file
Close #iFNum

'Set success flag and exit
iSprLoadFrames = True
Exit Function

LoadFrames_Err:
MsgBox "The following error occurred in iSprLoadGfx():" & Chr$(10) & Error$(Err)

'If file open then close it
If iOpen Then Close #iFNum

Exit Function
End Function

Function iSprLoadGfx(pic As PictureBox, ByVal vsFName As String) As Integer
'==AutoDoc==
'Purpose    Load sprite graphics from a *.BMP file into a
'           memory DC and create a mask DC for transparent
'           blitting as well
'Entry      pic - a picture box used to load the gfx
'           vsFName - Name of the *.BMP file to load
'Exit       True if file loaded and mask created
'Comments   The *.BMP file must reside in same directory
'           as the executable. All resources are released
'           if any errors occur

Dim i As Integer
Dim lW As Long
Dim lH As Long
Dim lGfxDC As Long
Dim lGfxBmp As Long
Dim lMaskDC As Long
Dim lMaskBmp As Long
Dim lSrcDC As Long
Dim iRetVal As Integer
Dim l As Long
Dim lColour As Long

'Exit if gfx are already loaded.
If mlGfxDC Then Exit Function

'Trap errors as we are accessing disk files
On Error GoTo SprLoadGfx_Err

'Make sure picture box is configured as required
pic.AutoRedraw = True
pic.AutoSize = True
pic.Visible = False

'Load gfx into a temporary Picture Box
pic.Picture = LoadPicture(App.Path & "/" & vsFName)

'Get useful picture box properties into locals
lW = pic.Width \ Screen.TwipsPerPixelX
lH = pic.Height \ Screen.TwipsPerPixelY
lSrcDC = pic.hdc

'Allocate a DC
lGfxDC = CreateCompatibleDC(mlGameDC)

'Allocate a Bitmap
If lGfxDC Then
    lGfxBmp = CreateCompatibleBitmap(lSrcDC, lW, lH)

    'Copy the gfx from the PictureBox into the DC
    If lGfxBmp Then
        lGfxBmp = SelectObject(lGfxDC, lGfxBmp)
        l = BitBlt(lGfxDC, 0, 0, lW, lH, lSrcDC, 0, 0, SRCCOPY)

        'Allocate a DC for masks
        lMaskDC = CreateCompatibleDC(mlGameDC)

        'Allocate a Bitmap for masks
        If lMaskDC Then
            lMaskBmp = CreateBitmap(lW, lH, 1, 1, ByVal 0&)

            'Create masks
            If lMaskBmp Then
                lMaskBmp = SelectObject(lMaskDC, lMaskBmp)
                lColour = SetBkColor(lGfxDC, QBColor(0))
                l = BitBlt(lMaskDC, 0, 0, lW, lH, lGfxDC, 0, 0, SRCCOPY)
                lColour = SetBkColor(lGfxDC, lColour)

                'Flag success and store variables
                iRetVal = True
                mlGfxDC = lGfxDC
                mlGfxBmp = lGfxBmp
                mlMaskDC = lMaskDC
                mlMaskBmp = lMaskBmp
            End If
        End If
    End If
End If

'If we failed for some reason then free all resources
If Not iRetVal Then

    'Free sprite gfx bitmap
    If lGfxBmp Then
        lGfxBmp = SelectObject(lGfxDC, lGfxBmp)
        l = DeleteObject(lGfxBmp)
    End If

    'Free sprite gfx DC
    If lGfxDC Then l = DeleteDC(lGfxDC)

    'Free mask bitmap
    If lMaskBmp Then
        lMaskBmp = SelectObject(lMaskDC, lMaskBmp)
        l = DeleteObject(lMaskBmp)
    End If

    'Free mask DC
    If lMaskDC Then l = DeleteDC(lMaskDC)

End If

'Set return code and exit
iSprLoadGfx = iRetVal
Exit Function

'Simple error handler
SprLoadGfx_Err:

'Inform user of the error
MsgBox "The following error occurred in iSprLoadGfx():" & Chr$(10) & Error$(Err)

'In case this was not a file error free resources
    
'Free sprite gfx bitmap
If lGfxBmp Then
    lGfxBmp = SelectObject(lGfxDC, lGfxBmp)
    l = DeleteObject(lGfxBmp)
End If

'Free sprite gfx DC
If lGfxDC Then l = DeleteDC(lGfxDC)

'Free mask bitmap
If lMaskBmp Then
    lMaskBmp = SelectObject(lMaskDC, lMaskBmp)
    l = DeleteObject(lMaskBmp)
End If

'Free mask DC
If lMaskDC Then l = DeleteDC(lMaskDC)

Exit Function
End Function

Sub SprActivateSprite(ByVal viId As Integer, ByVal vlX As Long, ByVal vlY As Long)
'==AutoDoc==
'Purpose    Activates a sprite and makes initial background
'           save
'Entry      viId - Index of sprite to activate
'           vlX - X pixel coord to display sprite at
'           vlY - Y pixel coord to display sprite at
'Comments

Dim i As Integer
Dim l As Long

'Exit if sprite is not allocated
If Not gtSpr(viId).iInUse Then Exit Sub

'Set the sprites X, Y coordinates
gtSpr(viId).lX = vlX
gtSpr(viId).lY = vlY

'Take a copy of background at (X,Y) where sprite will be displayed
l = BitBlt(gtSpr(viId).lSaveDC, 0, 0, gtSpr(viId).lW, gtSpr(viId).lH, mlGameDC, vlX, vlY, SRCCOPY)

'Mark the sprite as active
gtSpr(viId).iActive = True

End Sub

Sub SprAnimAuto()
'==AutoDoc==
'Purpose    Animate all active sprites that have iAnimAuto
'           set True
'Entry      None
'Comments   All animation sequences are assumed to be
'           cyclic.

Dim i As Integer
Dim iId As Integer
Dim iStart As Integer
Dim iEnd As Integer
Dim iFrame As Integer

'Get dimensions of the sprite array
iStart = LBound(gtSpr)
iEnd = UBound(gtSpr)

'For each active entry in gtSpr() with iAnimAuto set true
For iId = iStart To iEnd
    If gtSpr(iId).iActive And gtSpr(iId).iAnimAuto Then
        
        iFrame = gtSpr(iId).iFrame
        
        'Decrease iAnimCount
        gtSpr(iId).iAnimCount = gtSpr(iId).iAnimCount - 1

        'If iAnimCount is zero then
        If gtSpr(iId).iAnimCount = 0 Then
            
            'reset iAnimCount to value in iAnimRate
            gtSpr(iId).iAnimCount = gtSpr(iId).iAnimRate
            
            'bump iFrame
            iFrame = iFrame + 1

            'If iFrame > iLastFrame then reset iFrame to iFirstFrame
            If iFrame > gtSpr(iId).iLastFrame Then iFrame = gtSpr(iId).iFirstFrame
        End If
        
        'set iFrameX and iFrameY to values in gtSprFrm(iFrame)
        gtSpr(iId).iFrame = iFrame
        gtSpr(iId).lFrameX = gtSprFrm(iFrame).lX
        gtSpr(iId).lFrameY = gtSprFrm(iFrame).lY
    End If
Next iId

End Sub

Sub SprAnimNextFrame(ByVal viId As Integer)
'==AutoDoc==
'Purpose    To move a sprite one frame forward in its
'           animation sequence
'Entry      viId - Index of sprite to animate
'Comments   All animation sequences are assumed to be
'           cyclic

Dim iFrame As Integer

'Sprite must be active
If gtSpr(viId).iActive Then
    iFrame = gtSpr(viId).iFrame
        
    'bump iFrame
    iFrame = iFrame + 1

    'If iFrame > iLastFrame then reset iFrame to iFirstFrame
    If iFrame > gtSpr(viId).iLastFrame Then iFrame = gtSpr(viId).iFirstFrame
        
    'set iFrameX and iFrameY to values in gtSprFrm(iFrame)
    gtSpr(viId).iFrame = iFrame
    gtSpr(viId).lFrameX = gtSprFrm(iFrame).lX
    gtSpr(viId).lFrameY = gtSprFrm(iFrame).lY
End If

End Sub

Sub SprAnimPrevFrame(ByVal viId As Integer)
'==AutoDoc==
'Purpose    To move a sprite one frame forward in its
'           animation sequence
'Entry      viId - Index of sprite to animate
'Comments   All animation sequences are assumed to be
'           cyclic

Dim iFrame As Integer

'Sprite must be active
If gtSpr(viId).iActive Then
    iFrame = gtSpr(viId).iFrame
        
    'bump iFrame
    iFrame = iFrame - 1

    'If iFrame < iFirstFrame then reset iFrame to iLastFrame
    If iFrame < gtSpr(viId).iFirstFrame Then iFrame = gtSpr(viId).iLastFrame
    
    'set iFrameX and iFrameY to values in gtSprFrm(iFrame)
    gtSpr(viId).iFrame = iFrame
    gtSpr(viId).lFrameX = gtSprFrm(iFrame).lX
    gtSpr(viId).lFrameY = gtSprFrm(iFrame).lY
End If

End Sub

Sub SprAnimSetFrame(ByVal viId As Integer, ByVal viFrame As Integer)
'==AutoDoc==
'Purpose    To set the frame used by a sprite
'Entry      viId - Index of sprite to animate
'           viFrame - frame to use
'Comments   The frames specified can be any frame, there
'           is no requirement that it be a member of the
'           animation sequence of the sprite

'Sprite must be active
If gtSpr(viId).iActive Then
    
    'set iFrameX and iFrameY to values in gtSprFrm(iFrame)
    gtSpr(viId).iFrame = viFrame
    gtSpr(viId).lFrameX = gtSprFrm(viFrame).lX
    gtSpr(viId).lFrameY = gtSprFrm(viFrame).lY