frmplay.frm

也是坦克大战

VERSION 5.00
Begin VB.Form frmPlay 
   BorderStyle     =   0  'None
   Caption         =   "Tank War"
   ClientHeight    =   3195
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4680
   ControlBox      =   0   'False
   Icon            =   "frmPlay.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
End
Attribute VB_Name = "frmPlay"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim DirectX As DirectX7
Dim DDraw As DirectDraw7
Dim DSound As DirectSound
Dim DInput As DirectInput

Dim diDevice As DirectInputDevice

Dim Primary As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7

Dim Sounds As Collection    ' Store DirectSoundBuffer objects in this.

Dim tank1 As cTank
Dim tank2 As cTank
Dim Stars As Collection     ' Store cSprite Star in this.

Dim ddsd1 As DDSURFACEDESC2, ddsdScreen As DDSURFACEDESC2

Dim Surfaces As Collection  ' Store all other DirectDrawSurfaces in this.

Dim blnInitialized As Boolean

Dim intWinner As Integer

Dim Score(1 To 2) As Integer

Dim GameState As PlayStates

Private Enum PlayStates
    psStartUp = 0
    psPlaying = 1
    psEnd = 2
End Enum

Sub Init()
    On Local Error GoTo ErrHandler
    
    Set DirectX = New DirectX7
    Set DDraw = DirectX.DirectDrawCreate("")
    Set DSound = DirectX.DirectSoundCreate("")
    Set DInput = DirectX.DirectInputCreate
    
    ' ----- Direct Draw -------
    With DDraw
        .SetCooperativeLevel Me.hWnd, DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN
        .SetDisplayMode 640, 480, 16, 0, DDSDM_DEFAULT
    End With
    
    ' ------- Direct Sound -----
    DSound.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY
    
    ' ------ Direct Input -----
    Set diDevice = DInput.CreateDevice("GUID_SysKeyBoard")
    
    diDevice.SetCommonDataFormat DIFORMAT_KEYBOARD
    diDevice.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
    
    diDevice.Acquire
    
    ' -------- Primary ---------
    With ddsd1
        .lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
        .ddsCaps.lCaps = DDSCAPS_COMPLEX Or DDSCAPS_FLIP Or DDSCAPS_PRIMARYSURFACE
        .lBackBufferCount = 1
    End With
    
    Set Primary = DDraw.CreateSurface(ddsd1)
    
    ' ------- Backbuffer ------
    Dim caps As DDSCAPS2
    
    caps.lCaps = DDSCAPS_BACKBUFFER
    Set BackBuffer = Primary.GetAttachedSurface(caps)
    
    BackBuffer.GetSurfaceDesc ddsdScreen
    BackBuffer.SetFontTransparency True
    BackBuffer.SetForeColor 0
    With Me.Font
        .Name = "Courier New"
        .Size = 14
        .Bold = True
    End With
    BackBuffer.SetFont Me.Font
    
    InitSounds
    initSurfaces
    
    blnInitialized = True
    
    Exit Sub    ' Don't crash into ErrHandler!
    
ErrHandler:
    Debug.Print "Error init"
    Debug.Print Err.Description
    ' If we can't initialize DirectX then quit.
    EndIt
End Sub

Sub InitSounds()
    Set Sounds = New Collection
    
    Dim dsb As DirectSoundBuffer
    Dim bufferDesc As DSBUFFERDESC
    Dim waveFormat As WAVEFORMATEX
    Dim strFile As String
    
    bufferDesc.lFlags = DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME Or DSBCAPS_STATIC
    
    With waveFormat
        .nFormatTag = WAVE_FORMAT_PCM
        .nChannels = 1
        .lSamplesPerSec = 22050
        .nBitsPerSample = 16
        .nBlockAlign = .nBitsPerSample / 8 * .nChannels
        .lAvgBytesPerSec = .lSamplesPerSec * .nBlockAlign
    End With
    
    strFile = App.Path & "\explode.wav"
    Set dsb = DSound.CreateSoundBufferFromFile(strFile, bufferDesc, waveFormat)
    Sounds.Add dsb, "Explode1"
    Sounds.Add dsb, "Explode2"
    
    strFile = App.Path & "\score.wav"
    Set dsb = DSound.CreateSoundBufferFromFile(strFile, bufferDesc, waveFormat)
    Sounds.Add dsb, "Score"
End Sub

Sub initSurfaces()
    Dim dds As DirectDrawSurface7
    Dim key As DDCOLORKEY
    
    key.high = 0
    key.low = 0
    
    On Error Resume Next
    Surfaces.Remove "Tank"
    Surfaces.Remove "Bullet"
    Surfaces.Remove "Back"
    Surfaces.Remove "Star"
    Surfaces.Remove "StartUp"
    On Error GoTo 0
    
    ' ------ Back Ground ------
    With ddsd1
        .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        .lWidth = 640
        .lHeight = 480
    End With
    Set dds = DDraw.CreateSurfaceFromFile(App.Path & "\back.bmp", ddsd1)
    Surfaces.Add dds, "Back"
    
    ' ------- Tank ----------
    With ddsd1
        .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        .lWidth = 116
        .lHeight = 64
    End With
    Set dds = Nothing
    Set dds = DDraw.CreateSurfaceFromFile(App.Path & "\tank01.bmp", ddsd1)
    dds.SetColorKey DDCKEY_SRCBLT, key
    
    Surfaces.Add dds, "Tank"
    
    ' ------ Bullet -------
    Set dds = Nothing
    With ddsd1
        .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        .lWidth = 20
        .lHeight = 5
    End With
    Set dds = DDraw.CreateSurfaceFromFile(App.Path & "\bullet01.bmp", ddsd1)
    dds.SetColorKey DDCKEY_SRCBLT, key
    
    Surfaces.Add dds, "Bullet"
    
    ' ------ Star ---------
    Set dds = Nothing
    With ddsd1
        .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        .lWidth = 9
        .lHeight = 8
    End With
    Set dds = DDraw.CreateSurfaceFromFile(App.Path & "\Star01.bmp", ddsd1)
    dds.SetColorKey DDCKEY_SRCBLT, key
    
    Surfaces.Add dds, "Star"
    
    ' ------ StartUp -------
    Set dds = Nothing
    With ddsd1
        .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        .lWidth = 640
        .lHeight = 480
    End With
    Set dds = DDraw.CreateSurfaceFromFile(App.Path & "\startup.bmp", ddsd1)
    
    Surfaces.Add dds, "StartUp"
    
    
    initTanks
    initStars
End Sub

Sub initStars()
    Set Stars = New Collection
    
    Dim oStar As cSprite
    Dim i As Integer
    Randomize
    
    For i = 1 To 41
        Set oStar = New cSprite
        
        With oStar
            .LoadData App.Path & "\Star01.spr"
            .x = (Rnd * 520) + 100
            .Y = (Rnd * 440) + 20
            .Direction = dirUp
            Set .ddsBackBuffer = BackBuffer
            Set .ddsBitmap = Surfaces("Star")
        End With
        
        Stars.Add oStar
    Next i
End Sub

Sub Blt()
    Static Paused(1 To 2) As Integer
    
    If Not blnInitialized Then Exit Sub ' DirectX must be ready...
    
    On Local Error GoTo ErrHandler
    
    Dim blnRestore As Boolean
    Dim rc As RECT          ' Multi-use variable.
    
    blnRestore = False
    Do Until ExModeActive
        blnRestore = True
        DoEvents
    Loop
    
    DoEvents
    
    If blnRestore Then
        blnRestore = False
        DDraw.RestoreAllSurfaces
        Call initSurfaces
    End If
    
    ' Do drawing here...
    rc = AssignRect(0, 0, 640, 480)
    BackBuffer.BltFast 0, 0, Surfaces("Back"), rc, DDBLTFAST_WAIT
    'Debug.Print "Checking stars...";
    checkStars tank1
    checkStars tank2
    'Debug.Print "done"
    drawStars
    
    If Paused(1) = 0 Then
        tank1.moveTank
    Else
        Paused(1) = Paused(1) - 1
        tank1.MoveBullets
    End If
    If Paused(2) = 0 Then
        tank2.moveTank
    Else
        Paused(2) = Paused(2) - 1
        tank2.MoveBullets
    End If
    If tank1.Collsion(tank2) And Paused(2) = 0 Then
        PlaySound "Explode1"
        tank2.x = 620
        tank2.Y = 460
        tank2.Direction = dirLeft
        Paused(2) = 30
        tank1.Score = tank1.Score + tank2.Score
        tank2.Score = 0
    End If
    If tank2.Collsion(tank1) And Paused(1) = 0 Then
        PlaySound "Explode2"
        tank1.x = 120
        tank1.Y = 20
        tank1.Direction = dirRight
        Paused(1) = 30
        tank2.Score = tank2.Score + tank1.Score
        tank1.Score = 0
    End If
    tank1.drawTank
    tank2.drawTank
    drawScores
    
    Primary.Flip Nothing, DDFLIP_WAIT
    
    If Stars.Count = 0 Then intWinner = IIf(tank1.Score > tank2.Score, 1, 2)
    
    Exit Sub
ErrHandler:
    ' Just don't draw.
    Debug.Print Err.Number, Err.Description
End Sub

Sub EndIt()
    If Not (DDraw Is Nothing) Then
        With DDraw
            .RestoreAllSurfaces
            .SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
        End With
    End If
    
    diDevice.Unacquire
    
    Set DInput = Nothing
    Set diDevice = Nothing
    Set DSound = Nothing
    Set Sounds = Nothing
    Set Surfaces = Nothing
    Set Stars = Nothing
    Set Primary = Nothing
    Set BackBuffer = Nothing
    Set DDraw = Nothing
    Set DirectX = Nothing
    
    ShowCursor True
    Unload Me
    End
End Sub

Function ExModeActive() As Boolean
    Dim lngVal As Long
    
    lngVal = DDraw.TestCooperativeLevel
    
    ExModeActive = (lngVal = DD_OK)
End Function

Private Sub Form_Load()
    Dim rc As RECT
    Dim diState As DIKEYBOARDSTATE
    Dim blnRestore As Boolean
    Dim blnJustQuit As Boolean
    Dim l As Single
    
    Set Surfaces = New Collection
    
    ShowCursor False
    
    Me.Show
    DoEvents
    Init
    
    rc = AssignRect(0, 0, 640, 480)
    
    'On Error GoTo ErrStop
    
    Do
        diDevice.GetDeviceStateKeyboard diState
        
        Select Case GameState
        Case psStartUp
        
            Do Until ExModeActive
                blnRestore = True
                DoEvents
            Loop
            If blnRestore Then initSurfaces
            
            If Not blnJustQuit Then
                If diState.key(DIK_ESCAPE) Then
                    Exit Do
                End If
                If diState.key(DIK_RETURN) Then
                    initTanks
                    initStars
                    intWinner = 0
                    GameState = psPlaying
                End If
            Else
                If Timer > l + 0.2 Then blnJustQuit = False
            End If
            
            BackBuffer.BltFast 0, 0, Surfaces("StartUp"), rc, DDBLTFAST_WAIT
            Primary.Flip Nothing, DDFLIP_WAIT
            
            DoEvents
            
        Case psPlaying
            With diState
                If .key(DIK_UP) Then tank1.Direction = dirUp
                If .key(DIK_RIGHT) Then tank1.Direction = dirRight
                If .key(DIK_DOWN) Then tank1.Direction = dirDown
                If .key(DIK_LEFT) Then tank1.Direction = dirLeft
                If .key(DIK_RCONTROL) Then tank1.Fire
                
                If .key(DIK_W) Then tank2.Direction = dirUp
                If .key(DIK_D) Then tank2.Direction = dirRight
                If .key(DIK_S) Then tank2.Direction = dirDown
                If .key(DIK_A) Then tank2.Direction = dirLeft
                If .key(DIK_LCONTROL) Then tank2.Fire
            End With
            
            Blt
            
            If intWinner > 0 Then GameState = psEnd
            
            If diState.key(DIK_ESCAPE) Then
                DoEvents
                GameState = psStartUp
                l = Timer
                blnJustQuit = True
            End If
            
        Case psEnd
            BackBuffer.SetForeColor vbWhite
            BackBuffer.BltColorFill rc, 0
            BackBuffer.DrawText 200, 200, "Well Done Player " & CStr(intWinner), False
            BackBuffer.DrawText 200, 300, "Press Space to continue...", False
            Primary.Flip Nothing, DDFLIP_WAIT
            
            With diState
                If .key(DIK_SPACE) Then
                    GameState = psStartUp
                End If
            End With
            
        End Select
        
        DoEvents
    Loop Until False
    
ErrStop:
    If Err.Number <> 0 Then Debug.Print Err.Description
    
    DoEvents
    
    EndIt
End Sub

Private Sub Form_Paint()
    Blt
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmPlay = Nothing
End Sub

Sub drawScores()
    BackBuffer.DrawText 50, 70, CStr(tank1.Score), False
    BackBuffer.DrawText 50, 119, CStr(tank2.Score), False
End Sub

Sub drawStars()
    Dim oStar As cSprite
    
    For Each oStar In Stars
        oStar.drawSprite
    Next
End Sub

Sub checkStars(tank As cTank)
    Dim oStar As cSprite
    Dim tmp As Collection
    Dim i As Integer
    Dim blnRemoved As Boolean
    Set tmp = Stars
    
    For i = tmp.Count To 1 Step -1
        Set oStar = tmp(i)
        If RectCollision(oStar.RectOnScreen, tank.RectOnScreen) Then
            'Debug.Print "Removing " & i
            Stars.Remove i
            'Debug.Print "done"
            tank.Score = tank.Score + 100
            blnRemoved = True
        End If
    Next i
    
    If blnRemoved Then PlaySound "Score"
End Sub

Sub PlaySound(strKey As String)
    Dim dsb As DirectSoundBuffer
    
    Set dsb = Sounds(strKey)
    dsb.Play DSBPLAY_DEFAULT
End Sub

Sub initTanks()
    Set tank1 = New cTank
    With tank1
        .initTank Surfaces("Tank"), BackBuffer, Surfaces("Bullet")
        .x = 120
        .Y = 20
        .Group = 1
        .Speed = 10
        .ClearBullets
        .Score = 0
    End With
    
    Set tank2 = New cTank
    With tank2
        .initTank Surfaces("Tank"), BackBuffer, Surfaces("Bullet")
        .x = 620
        .Y = 460
        .Group = 2
        .Speed = 10
        .Direction = dirLeft
        .ClearBullets
        .Score = 0
    End With
End Sub