spreng.bas

八脚蟹》射击游戏源码

End If

End Sub

Sub SprAnimSetFrameRel(ByVal viId As Integer, ByVal viRel As Integer)
'==AutoDoc==
'Purpose    To set the frame used by a sprite from its
'           animation sequence
'Entry      viId - Index of sprite to animate
'           viRel - Offset to required frame, 0=iFirstFrame
'                   , 1=iFirstFrame+1,....
'Comments   The is no bounds checking done on the offset,
'           make sure it stays within iFirstFrame to
'           iLastFrame range!

Dim iFrame As Integer

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

    '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 SprClearPlayDC()
'==AutoDoc==
'Purpose    Clears the paly DC ready for new gfx
'Entry      None.
'Exit       None.
'Comments   One of Marks routines!

Dim l As Long

'Only proceed if there is a DC to load into
If mlGameDC Then
    'Clear the play DC
    l = BitBlt(mlGameDC, 0, 0, mlGameW, mlGameH, mlGameDC, 0, 0, SRCERASE)
End If

End Sub

Sub SprDeactivateSprite(ByVal viId As Integer)
'==AutoDoc==
'Purpose    Deactivates a sprite
'Entry      viId - Index of sprite to deactivate
'Comments

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

'Mark sprite as inactive
gtSpr(viId).iActive = False

End Sub

Sub SprDraw()
'==AutoDoc==
'Purpose    Save background and draw all sprites
'Entry      None
'Comments   Call this in game loop AFTER activating,
'           moving, deactivating sprites.

Dim i As Integer
Dim lX As Long
Dim lY As Long
Dim lW As Long
Dim lH As Long
Dim lGfxX As Long
Dim lGfxY As Long
Dim lSaveDC As Long
Dim iStart As Integer
Dim iEnd As Integer
Dim iId As Integer
Dim l As Long

'Exit if there is no play area DC
If mlGameDC = 0 Then Exit Sub

'Get size of array
iStart = LBound(gtSpr)
iEnd = UBound(gtSpr)

'For each active sprite in gtSpr(), working forwards through the array
For iId = iStart To iEnd
    If gtSpr(iId).iActive Then
        
        'Get working data
        lX = gtSpr(iId).lX
        lY = gtSpr(iId).lY
        
        lGfxX = gtSpr(iId).lFrameX
        lGfxY = gtSpr(iId).lFrameY
        lW = gtSpr(iId).lW
        lH = gtSpr(iId).lH
        lSaveDC = gtSpr(iId).lSaveDC

        'Copy data from background into sprites save DC where sprite is to be displayed
        l = BitBlt(lSaveDC, 0, 0, lW, lH, mlGameDC, lX, lY, SRCCOPY)
        
        'Copy sprite data into background using transparent blitting
        l = BitBlt(mlGameDC, lX, lY, lW, lH, mlMaskDC, lGfxX, lGfxY, SRCAND)
        l = BitBlt(mlGameDC, lX, lY, lW, lH, mlGfxDC, lGfxX, lGfxY, SRCINVERT)
        
    End If
Next iId

End Sub

Sub SprFreeAll()
'==AutoDoc==
'Purpose    Free all sprite engine resources
'Entry      None
'Exit       None
'Comments   Call this just before program termination

'Free resources used by sprites
SprFreeAllSprites

'Free resources used to hold sprite graphics and masks
SprFreeGfx

'Free the play area DC
SprFreePlayDC

End Sub

Sub SprFreeAllSprites()
'==AutoDoc==
'Purpose    Free resources used by all sprites and mark
'           them as available
'Entry      None
'Comments

Dim i As Integer
Dim iStart As Integer
Dim iEnd As Integer

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

'Free all the sprites
For i = iStart To iEnd
    SprFreeSprite i
Next i

End Sub

Sub SprFreeGfx()
'==AutoDoc==
'Purpose    Free resources used to hold sprite graphics
'           and masks
'Entry      None

Dim i As Integer
Dim l As Long

'Free sprite gfx bitmap
If mlGfxBmp Then
    mlGfxBmp = SelectObject(mlGfxDC, mlGfxBmp)
    l = DeleteObject(mlGfxBmp)
End If

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

'Free mask bitmap
If mlMaskBmp Then
    mlMaskBmp = SelectObject(mlMaskDC, mlMaskBmp)
    l = DeleteObject(mlMaskBmp)
End If

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

End Sub

Sub SprFreePlayDC()
'==AutoDoc==
'Purpose    Release resources used for the game play area
'Entry      None
'Comments

Dim i As Integer
Dim l As Long

'If Bitmap exists select it out of DC and free it
If mlGameBmp Then
    mlGameBmp = SelectObject(mlGameDC, mlGameBmp)
    l = DeleteObject(mlGameBmp)
    mlGameBmp = 0
End If

'If DC exists free it
If mlGameDC Then
    l = DeleteDC(mlGameDC)
    mlGameDC = 0
End If

End Sub

Sub SprFreeSprite(ByVal viId As Integer)
'==AutoDoc==
'Purpose    Free resources used by a sprite and mark it
'           as available
'Entry      viId - Index value of the sprite to free
'Comments

Dim i As Integer
Dim l As Long

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

'If there is a save Bitmap select it out of DC and free it
If gtSpr(viId).lSaveBmp Then
    gtSpr(viId).lSaveBmp = SelectObject(gtSpr(viId).lSaveDC, gtSpr(viId).lSaveBmp)
    l = DeleteObject(gtSpr(viId).lSaveBmp)
End If

'If there is a save DC free it
If gtSpr(viId).lSaveDC Then l = DeleteDC(gtSpr(viId).lSaveDC)

'Mark the sprite as not allocated
gtSpr(viId).iInUse = False
gtSpr(viId).iActive = False
gtSpr(viId).lSaveBmp = 0    'Saftey measure!
gtSpr(viId).lSaveDC = 0

End Sub

Sub SprMoveSprite(ByVal viId As Integer, ByVal vlX As Long, ByVal vlY As Long)
'==AutoDoc==
'Purpose    To move a sprite to absolute coordinates
'Entry      viId - Spride index
'           vlX - X pixel coordinate
'           vlY - Y pixel coordinate
'Comments

'Exit if sprite is not active
If Not gtSpr(viId).iActive Then Exit Sub

'Update sprites iX and iY fields
gtSpr(viId).lX = vlX
gtSpr(viId).lY = vlY

End Sub

Sub SprMoveSpriteRel(ByVal viId As Integer, ByVal vlDx As Long, ByVal vlDy As Long)
'==AutoDoc==
'Purpose    To move a sprite relative to its current
'           position
'Entry      viId - Spride index
'           vlDx - X pixel offset (+ or -)
'           vlDy - Y pixel offset (+ or -)
'Comments

'Exit if sprite is not active
If Not gtSpr(viId).iActive Then Exit Sub

'Update sprites iX and iY fields
gtSpr(viId).lX = gtSpr(viId).lX + vlDx
gtSpr(viId).lY = gtSpr(viId).lY + vlDy

End Sub

Sub SprRestore()
'==AutoDoc==
'Purpose    Restores background where all sprites have
'           been displayed.
'Entry      None
'Comments   Call this in game loop BEFORE deactivating
'           sprites.

Dim i As Integer
Dim iStart As Integer
Dim iEnd As Integer
Dim iId As Integer
Dim l As Long

'Exit if there is no play area DC
If mlGameDC = 0 Then Exit Sub

'Get size of array
iStart = LBound(gtSpr)
iEnd = UBound(gtSpr)

'For each active sprite in gtSpr(), working backwards through the array
For iId = iEnd To iStart Step -1
    
    'Copy data from sprites save DC into the background where sprite was displayed
    If gtSpr(iId).iActive Then l = BitBlt(mlGameDC, gtSpr(iId).lX, gtSpr(iId).lY, gtSpr(iId).lW, gtSpr(iId).lH, gtSpr(iId).lSaveDC, 0, 0, SRCCOPY)

Next iId

End Sub

Sub SprSetBackground(rsFName As String, picTmp As PictureBox)
'==AutoDoc==
'Purpose    Load a bitmap file into the play DC as a
'           background image
'Entry      rsFName - Name of file to load, must reside in
'                     the same directory as the executable
'           picTmp - PictureBox used to load the image
'Exit       None.
'Comments   One of Marks routines!
'           You can use this routine to display Splash
'           Screens in the play area while running in demo
'           mode or whatever!

Dim i As Integer
Dim l As Long
Dim lX As Long
Dim lY As Long
Dim iSMode As Integer

'Accessing files so trap errors
On Error GoTo SprSetBackground_Err

'Only proceed if there is a DC to load into
If mlGameDC Then
    'Change scale mode of pic box to be safe
    iSMode = picTmp.ScaleMode
    picTmp.ScaleMode = PIXELS
    'Load the picture
    picTmp.Picture = LoadPicture(App.Path & "/" & rsFName)
    'If smaller than play area, center it
    If picTmp.ScaleWidth < mlGameW Then lX = (mlGameW - picTmp.ScaleWidth) \ 2
    If picTmp.ScaleHeight < mlGameH Then lY = (mlGameH - picTmp.ScaleHeight) \ 2
    'Copy it into the play DC
    l = BitBlt(mlGameDC, lX, lY, mlGameW, mlGameH, picTmp.hdc, 0, 0, SRCCOPY)
    'Restore scale mode of pic box
    picTmp.ScaleMode = iSMode
End If

Exit Sub
SprSetBackground_Err:
'Debug.Print App.Path & "/" & rsFName
Exit Sub
End Sub

Sub SprShowPlayDC(ByVal vlDstDc As Long, ByVal vlX As Long, ByVal vlY As Long)
'==AutoDoc==
'Purpose    Display the play area
'Entry      vlDstDC - Target DC to copy play area into
'           vlX - X pixel coord in target DC
'           vlY - Y pixel coord in target DC

Dim l As Long

'If play DC exists then copy it to the specified DC at specified position.
If mlGameDC Then l = BitBlt(vlDstDc, vlX, vlY, mlGameW, mlGameH, mlGameDC, 0, 0, SRCCOPY)

End Sub