spreng.bas

八脚蟹》射击游戏源码

Attribute VB_Name = "SPRENG"
Option Explicit
'==File==
'==AutoDoc==
'               Sprite Engine v1.2
'
'                       Copyright Mark Meany, 1997.
'
'Introduction
'
'This Visual Basic v3 Sprite Engine is Freeware, it has been provided
'for you to use in your own games providing the conditions laid out
'below are followed:
'
'  1. It is accompanied by a link back to this my site.
'     http://www.geocities.com/SiliconValley/Bay/9520/index.html
'
'  2. This copyright notice is included in the accompanying documentation.
'     Documentation means: Text files, help files and About dialog.
'
'  3. Due credit is given:
'     That means documentation includes: Some source cM.Meany, 1997.
'
'Disclaimer: This code is provided 'as is', no warranties expressed or
'implied.  You use this code on the understanding that the consequences
'of doing so are soley your responsability.
'
'For examples of the Sprite Engine in use, visit my web site and
'download some of the games from there:
'
'http://www.geocities.com/SiliconValley/Bay/9520/index.html
'
'Live fast, code hard and die in a beautiful way.
'
'Mark.
'
'========================================================================================
'Module Name    Sprite Engine
'Copyright      Mark Meany, 1997
'Version        v1.2
'Release Date   1st September 1997
'
'Know Bugs
'
'Palette Corruption    Occurs when certain programs are running, eg Internet Explorer 3
'                      I think I need to realise palettes at some point, but have yet to
'                      experiment with this.
'
'Revision History
'
' 07 Oct 1997 v1.2      SprSetBackground()
'                       Changed so it centers pictures smaller than the play area in the
'                       play area.  This alteration was made to accomodate Splash Screens.
'
' 19 Sept 1997 v1.1     iSprLoadFrames()
'                       Fixed to work with frame files generated by my Frame Editor v2
'                       Handles files in XSrc,YSrc,XDst,YDst as opposed to X,Y,W,H.
'========================================================================================

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'User defined types

'Frame structure
Type SprFrame
    lX As Long                  'X pixel coord of frame TopLeft
    lY As Long                  'Y pixel coord of frame TopLeft
    lW As Long                  'Pixel width of frame
    lH As Long                  'Pixel height of frame
End Type

'Sprite structure
Type SprSprite
    iInUse As Integer           'True if sprite is allocated
    iActive As Integer          'True if sprite is displayed
    lX As Long                  'X position at which last drawn
    lY As Long                  'Y position at which last drawn
    lW As Long                  'Pixel width of sprite
    lH As Long                  'Pixel height of sprite
    iFrame As Integer           'Current frame index into gtSprFrm()
    lFrameX As Long             'X offset into sprite graphics DC
    lFrameY As Long             'Y offset into sprite graphics DC
    lSaveDC As Long             'DC for background saves
    lSaveBmp As Long            'Bitmap for background saves
    iFirstFrame As Integer      'Index of first frame in anim sequence
    iLastFrame As Integer       'Index of last frame in anim sequence
    iAnimAuto As Integer        'True if animation is controlled by Sprite Engine
    iAnimRate As Integer        'Speed of animation (cycles per frame)
    iAnimCount As Integer       'Down counter until next frame of anim
    iUsr1 As Integer            'User data
    iUsr2 As Integer            'User data
    iUsr3 As Integer            'User data
End Type

'New Sprite Structure
Type SprNewSprite
    iId As Integer              'Index of sprite to allocate
    iFirstFrame As Integer      'First Anim Sequence frame
    iLastFrame As Integer       'Last Anim Sequence frame
    iAnimFlag As Integer        'True if Auto animated sprite
    iAnimRate As Integer        'Animation Speed
End Type

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Constants

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Global Variables

Global gtSprFrm() As SprFrame   'Holds all frame details
Global gtSpr() As SprSprite     'Holds all sprite details

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Module Variables
Dim mlGameDC As Long         'memory DC for game play area
Dim mlGameBmp As Long        'Bitmap for game play area
Dim mlGameW As Long          'Pixel width of play area
Dim mlGameH As Long          'Pixel height of play area
Dim mlGfxDC As Long              'DC for sprite graphics data
Dim mlGfxBmp As Long             'Bitamp for sprite graphics data
Dim mlMaskDC As Long             'DC for sprite mask data
Dim mlMaskBmp As Long            'Bitmap for sprite mask data

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'API Constants & Types

'Constants for BitBlt() copy modes
Global Const SRCCOPY = &HCC0020
Global Const SRCAND = &H8800C6
Global Const SRCPAINT = &HEE0086
Global Const NOTSRCCOPY = &H330008
Global Const SRCERASE = &H440328
Global Const SRCINVERT = &H660046

'Constants for objects Scale Mode
'Global Const TWIPS = 1
Global Const PIXELS = 3
Global Const RES_INFO = 2
Global Const MINIMIZED = 1

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'API Function Imports

'Windows resources functions
'Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
'Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC As Integer) As Integer
'Declare Function CreateBitmap Lib "GDI" (ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal nPlanes As Integer, ByVal nBitCount As Integer, ByVal lpBits As Any) As Integer
'Declare Function CreateCompatibleBitmap Lib "GDI" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
'Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
'Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
'Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer
'Declare Function SetBkColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
'Declare Function sndPlaySound Lib "MMSystem" (lpsound As Any, ByVal flag As Integer) As Integer

'Windows resources functions for VB 4 & 5 users
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
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Function iSprAllocateSprite(rtNew As SprNewSprite) As Integer
'==AutoDoc==
'Purpose    Allocate a sprite from the system, creates a
'           Save DC for background saving and initialises
'           all fields of the Sprite structure based on
'           values passed in the New Sprite structure.
'Entry      rtNew - A SprNewSprite structure that defines
'                   the sprite to allocate.
'Exit       True if sprite allocated successfully
'Comments   Resources are freed should an error occur

Dim i As Integer
Dim l As Long
Dim lX As Long
Dim lY As Long
Dim lW As Long
Dim lH As Long
Dim lSaveDC As Long
Dim lSaveBmp As Long
Dim iRetVal As Integer

'If there is no play area DC then exit
If mlGameDC = 0 Then Exit Function

'If the requested sprite is already allocated then exit
If gtSpr(rtNew.iId).iInUse Then Exit Function

'Get some values to work with
lX = gtSprFrm(rtNew.iFirstFrame).lX
lY = gtSprFrm(rtNew.iFirstFrame).lY
lW = gtSprFrm(rtNew.iFirstFrame).lW
lH = gtSprFrm(rtNew.iFirstFrame).lH

'Allocate a save DC based on size of first animation frame
lSaveDC = CreateCompatibleDC(mlGameDC)

'Allocate a save Bitmap based on size of first animation frame
If lSaveDC Then
    lSaveBmp = CreateCompatibleBitmap(mlGameDC, lW, lH)
    If lSaveBmp Then
        lSaveBmp = SelectObject(lSaveDC, lSaveBmp)

        'Fill in fields of gtSpr() for this sprite and flag success
        gtSpr(rtNew.iId).iInUse = True
        gtSpr(rtNew.iId).iActive = False
        gtSpr(rtNew.iId).lX = 0
        gtSpr(rtNew.iId).lY = 0
        gtSpr(rtNew.iId).lW = lW
        gtSpr(rtNew.iId).lH = lH
        gtSpr(rtNew.iId).iFrame = rtNew.iFirstFrame
        gtSpr(rtNew.iId).lFrameX = lX
        gtSpr(rtNew.iId).lFrameY = lY
        gtSpr(rtNew.iId).lSaveDC = lSaveDC
        gtSpr(rtNew.iId).lSaveBmp = lSaveBmp
        gtSpr(rtNew.iId).iFirstFrame = rtNew.iFirstFrame
        gtSpr(rtNew.iId).iLastFrame = rtNew.iLastFrame
        gtSpr(rtNew.iId).iAnimAuto = rtNew.iAnimFlag
        gtSpr(rtNew.iId).iAnimRate = rtNew.iAnimRate
        gtSpr(rtNew.iId).iAnimCount = rtNew.iAnimRate
        iRetVal = True
    Else
        'Error allocating bitmap, free DC
        l = DeleteDC(lSaveDC)
    End If
End If

'Return success
iSprAllocateSprite = iRetVal

End Function

Function iSprCollision(ByVal viId1 As Integer, ByVal viId2 As Integer) As Integer
'==AutoDoc==
'Purpose    To determine if two sprites have collided
'Entry      viId1 - Index of first sprite
'           viId2 - Index of second sprite
'Exit       True if sprites have hit
'Comments   This uses a crude overlapping rectangles
'           algorithm that causes yells of 'that missed
'           me by miles' to be screamed by disgruntled
'           players;)

Dim iRetVal As Integer

'Both sprites must be active
If Not (gtSpr(viId1).iActive And gtSpr(viId2).iActive) Then Exit Function

'Default to a collision
iRetVal = True

'Check if collision is impossible
If ((gtSpr(viId2).lX + gtSpr(viId2).lW - 1) < gtSpr(viId1).lX) Then iRetVal = False
If ((gtSpr(viId2).lY + gtSpr(viId2).lH - 1) < gtSpr(viId1).lY) Then iRetVal = False
If (gtSpr(viId2).lX > (gtSpr(viId1).lX + gtSpr(viId1).lW - 1)) Then iRetVal = False
If (gtSpr(viId2).lY > (gtSpr(viId1).lY + gtSpr(viId1).lH - 1)) Then iRetVal = False

'Return success
iSprCollision = iRetVal

End Function

Function iSprCollisionRange(ByVal viId As Integer, ByVal viStart As Integer, ByVal viEnd As Integer) As Integer
'==AutoDoc==
'Purpose    To determine if two sprites have collided
'Entry      viId - Index of first sprite
'           viStart - Index of first sprite in range
'           viEnd - Index of last sprite in range
'Exit       False if no collisions encountered, else
'           returns the ID+1 of the sprite hit
'Comments   This uses a crude overlapping rectangles
'           algorithm

Dim iId As Integer
Dim iRetVal As Integer

For iId = viStart To viEnd

    'Both sprites must be active
    If gtSpr(viId).iActive And gtSpr(iId).iActive Then

        'Default to a collision
        iRetVal = iId + 1

        'Check if collision is impossible
        If ((gtSpr(iId).lX + gtSpr(iId).lW - 1) < gtSpr(viId).lX) Then iRetVal = False
        If ((gtSpr(iId).lY + gtSpr(iId).lH - 1) < gtSpr(viId).lY) Then iRetVal = False
        If (gtSpr(iId).lX > (gtSpr(viId).lX + gtSpr(viId).lW - 1)) Then iRetVal = False
        If (gtSpr(iId).lY > (gtSpr(viId).lY + gtSpr(viId).lH - 1)) Then iRetVal = False

        'Quit checking as soon as we get a hit
        If iRetVal Then Exit For
    End If

Next iId

'Return success
iSprCollisionRange = iRetVal

End Function

Function iSprGetPlayDC(ByVal vlDstDc As Long, ByVal vlW As Long, ByVal vlH As Long) As Integer
'==AutoDoc==
'Purpose    Creates a DC to use as the play area
'Entry      viDstDC - DC that the play area will be displayed on
'           viW - Width of play area in pixels
'           viH - Height of play area in pixels
'Exit       True if resources allocated, false otherwise
'Comments   Will exit false if a play area is already in use

Dim i As Integer
Dim l As Long
Dim lDC As Long
Dim lBmp As Long
Dim iRetVal As Integer

'If a play area already exists then exit now
If mlGameDC Then Exit Function

'Get a DC
lDC = CreateCompatibleDC(vlDstDc)

'Only proceed on success
If lDC Then

    'Get a Bitmap
    lBmp = CreateCompatibleBitmap(vlDstDc, vlW, vlH)

    'Only proceed on success
    If lBmp Then

        'Select bitmap into DC
        lBmp = SelectObject(lDC, lBmp)

        'Save new resource handles in module variables
        mlGameDC = lDC
        mlGameBmp = lBmp
        mlGameW = vlW
        mlGameH = vlH

        'Flag success
        iRetVal = True

        'Clear the play area
        l = BitBlt(mlGameDC, 0, 0, vlW, vlH, mlGameDC, 0, 0, SRCERASE)
    
    Else

        'Bitmap could not be allocated, free the DC
        l = DeleteDC(lDC)
    
    End If

End If

'Return success of operation
iSprGetPlayDC = iRetVal

End Function