game.bas

3D射击游戏源码for VB还不错的

                ActSel = ActSel - 1
                ReDraw = True
            End If
            PressState = True
        ElseIf KeybState.Key(208) = 0 Then
            PressState = False
        End If
        
        If Not KeybState.Key(208) = 0 Then
            If Not PressState And Not ActSel = MaxSel Then
                ActSel = ActSel + 1
                ReDraw = True
            End If
            PressState = True
        ElseIf KeybState.Key(200) = 0 Then
            PressState = False
        End If
        
        'Return
        If Not KeybState.Key(28) = 0 Or Not KeybState.Key(156) = 0 Then
            ActChoice = ActSel
        End If
        
        If ReDraw Then
            ClearMenu
            SetMenuColor ActSel, 0
            Mk3d.PrimarySurf.DrawText TextCentralX(16), TextCentralY(0, 4, 40), "Start a new game", False
            SetMenuColor ActSel, 1
            Mk3d.PrimarySurf.DrawText TextCentralX(9), TextCentralY(1, 4, 40), "Highscore", False
            SetMenuColor ActSel, 2
            Mk3d.PrimarySurf.DrawText TextCentralX(7), TextCentralY(2, 4, 40), "Credits", False
            SetMenuColor ActSel, 3
            Mk3d.PrimarySurf.DrawText TextCentralX(9), TextCentralY(3, 4, 40), "Exit game", False
        End If
        ReDraw = False
        Mk3d.PrimarySurf.SetForeColor vbBlack
        
        If Not ActChoice = -1 Then
            ClearMenu
            Select Case ActChoice
                Case 0
                    'start the game
                    Mk3d.PrimarySurf.SetForeColor vbBlack
                    Mk3d.PrimarySurf.DrawText TextCentralX(24), TextCentralY(0, 1, 40), "Loading - please wait...", False
                    Game.Load FirstPlay
                    Game.Initsialize
                    Mk3d.diDeviceMouse.Acquire
                    Score = Game.Run
                    ClearMenu
                    Mk3d.diDeviceMouse.Unacquire
                    dsWalkSound.Stop
                    dsShootSound.Stop
                    FirstPlay = False
                    'check if the scrore is a record
                    Open App.Path & "\Data\Highscore.dat" For Random As #1 Len = 16
                    For i = 0 To 4
                        Get #1, i * 2 + 1, RecNames(i)
                        Get #1, i * 2 + 2, RecScores(i)
                    Next i
                    Close #1
                    RecInd = -1
                    For i = 0 To 4
                        If Score > RecScores(i) Then
                            'in the highscore!
                            For j = 4 To i + 1 Step -1
                                RecNames(j) = RecNames(j - 1)
                                RecScores(j) = RecScores(j - 1)
                            Next j
                            RecNames(i) = YName
                            RecScores(i) = Score
                            RecInd = i
                            Exit For
                        End If
                    Next i
                    Open App.Path & "\Data\Highscore.dat" For Random As #1 Len = 16
                    For i = 0 To 4
                        Put #1, i * 2 + 1, RecNames(i)
                        Put #1, i * 2 + 2, RecScores(i)
                    Next i
                    Close #1
                    ClearMenu
                    Mk3d.PrimarySurf.SetForeColor vbBlack
                    ShowHighscore Score, True, RecInd
                    ReDraw = True
                Case 1
                    'show highscore
                    ShowHighscore 0, False, 0
                    ReDraw = True
                Case 2
                    'show credits
                    Mk3d.PrimarySurf.DrawText TextCentralX(7), TextCentralY(0, 6, 40), "CREDITS", False
                    Mk3d.PrimarySurf.DrawText TextCentralX(26), TextCentralY(2, 6, 40), "Programmer: Mathias Kunter", False
                    Mk3d.PrimarySurf.DrawText TextCentralX(28), TextCentralY(3, 6, 40), "Mail: [e-mail]", False
                    Mk3d.PrimarySurf.DrawText TextCentralX(15), TextCentralY(5, 6, 40), "ESC to continue", False
                    WaitForESC
                    ReDraw = True
                Case 3
                    'exit game
                    Mk3d.ExitDX
                    DoEvents
                    End
            End Select
            ReDraw = True
        End If
    Loop While Not ActChoice = MaxSel
End Sub

Private Sub ShowHighscore(ByVal YScore As Integer, ByVal ShowYScore As Boolean, ByVal RecInd As Integer)
    Dim i%, RecNames$(4), RecScores%(4)
    
    Open App.Path & "\Data\Highscore.dat" For Random As #1 Len = 16
    For i = 0 To 4
        Get #1, i * 2 + 1, RecNames(i)
        Get #1, i * 2 + 2, RecScores(i)
    Next i
    Close #1
    
    Mk3d.PrimarySurf.DrawText TextCentralX(9), TextCentralY(0, 10, 40), "HIGHSCORE", False
    For i = 0 To 4
        If Not RecNames(i) = "" Then
            If ShowYScore And i = RecInd Then
                Mk3d.PrimarySurf.SetForeColor vbRed
            Else
                Mk3d.PrimarySurf.SetForeColor vbBlack
            End If
            Mk3d.PrimarySurf.DrawText TextCentralX(Len(i + 1 & ".: " & RecScores(i) & " points of " & RecNames(i))), TextCentralY(i + 2, 10, 40), i + 1 & ".: " & RecScores(i) & " points of " & RecNames(i), False
        End If
    Next i
    Mk3d.PrimarySurf.SetForeColor vbBlack
    If ShowYScore Then
        Mk3d.PrimarySurf.DrawText TextCentralX(Len("This game: " & YScore & " points")), TextCentralY(8, 10, 40), "This game: " & YScore & " points", False
        Mk3d.PrimarySurf.DrawText TextCentralX(15), TextCentralY(9, 10, 40), "ESC to continue", False
    Else
        Mk3d.PrimarySurf.DrawText TextCentralX(15), TextCentralY(9, 10, 40), "ESC to continue", False
    End If
    
    WaitForESC
End Sub

Private Sub WaitForESC()
    Dim KeybState As DIKEYBOARDSTATE
    
    Do
        DoEvents
        Mk3d.diDeviceKeyb.GetDeviceStateKeyboard KeybState
    Loop While KeybState.Key(1) = 0
End Sub

Private Sub ClearMenu()
    Dim EmptyRect As RECT

    Mk3d.PrimarySurf.Blt EmptyRect, MenuBackgr, EmptyRect, DDBLT_DONOTWAIT
    Mk3d.d3dDevice.BeginScene
    Mk3d.d3dDevice.Clear 1, Mk3d.d3drcViewport(), D3DCLEAR_TARGET, Mk3d.dx.CreateColorRGB(1, 1, 1), 0, 0
    Mk3d.d3dDevice.EndScene
    Mk3d.PrimarySurf.Flip Nothing, DDFLIP_DONOTWAIT
End Sub

Private Sub SetMenuColor(ByVal ActSel As Integer, NowSel As Integer)
    If ActSel = NowSel Then
        Mk3d.PrimarySurf.SetForeColor vbRed
    ElseIf Mk3d.PrimarySurf.GetForeColor = vbRed Then
        Mk3d.PrimarySurf.SetForeColor vbBlack
    End If
End Sub

Private Function TextCentralX(ByVal TextLen As Integer) As Integer
    TextCentralX = Mk3d.VPSize(0) / 2 - (GameFont.Size - 4) * TextLen / 2
End Function

Private Function TextCentralY(ByVal ActLine As Integer, ByVal NrLines As Integer, ByVal LinesDff As Integer) As Integer
    TextCentralY = Mk3d.VPSize(1) / 2 - LinesDff * (NrLines / 2 - ActLine)
End Function





Private Function GameKeyboard(yLookDir As D3DVECTOR) As Boolean
    Dim KeybState As DIKEYBOARDSTATE
    Dim yWalkDir As D3DVECTOR, yPosBef As D3DVECTOR, yCollDet As D3DVECTOR
    Dim RotAngle!, cntEnable%
    
    Mk3d.diDeviceKeyb.GetDeviceStateKeyboard KeybState
    If Not KeybState.Key(1) = 0 Then
        'ESC, go to the menu
        Do
            DoEvents
            Mk3d.diDeviceKeyb.GetDeviceStateKeyboard KeybState
        Loop While Not KeybState.Key(1) = 0                     'wait until ESC is no longer pressed
        GameKeyboard = True
        Exit Function
    End If
    RotAngle = GetMoveAngle(KeybState)
    If Not RotAngle = -1 Then
        yWalkDir = yLookDir
        yWalkDir.y = 0
        Mk3d.dx.VectorNormalize yWalkDir
        yWalkDir = Mk3d.VectorRotate(yWalkDir, Mk3d.VectorMake(0, RotAngle, 0))
        Mk3d.dx.VectorScale yWalkDir, yWalkDir, WalkSpeed * FrameT
        
        'Collision Detection
        yPosBef = yPos
        Mk3d.dx.VectorAdd yPos, yPos, yWalkDir
        yCollDet = GetCollDet(yPosBef, yPos, 2, False, True)
        If yCollDet.x = 0 Then
            yWalkDir.x = 0
            yPos = yPosBef
            cntEnable = cntEnable + 1
        End If
        If yCollDet.z = 0 Then
            yWalkDir.z = 0
            yPos = yPosBef
            cntEnable = cntEnable + 1
        End If
        If cntEnable = 1 Then
            'only if of the two values is zero. if both are zero, you can't walk in ANY direction
            Mk3d.dx.VectorNormalize yWalkDir
            Mk3d.dx.VectorScale yWalkDir, yWalkDir, WalkSpeed * FrameT
            Mk3d.dx.VectorAdd yPos, yPos, yWalkDir
        End If
        Mk3d.dx.VectorAdd yEyes, yEyes, yWalkDir
        If Not cntEnable = 2 Then
            'start playing the walk sound
            dsWalkSound.Play DSBPLAY_LOOPING
        Else
            'stop playing the walk sound
            dsWalkSound.Stop
            dsWalkSound.SetCurrentPosition 0
        End If
        
        'move also MG
        If Not MGHoldingState = MG_NONE Then
            Mk3d.dx.VectorAdd MGHoldingPos, MGHoldingPos, yWalkDir
            MGHolding.MoveTo MGHoldingPos
        End If
    Else
        'stop playing the walk sound
        dsWalkSound.Stop
        dsWalkSound.SetCurrentPosition 0
    End If
End Function


Private Sub GameMouse()
    Dim MouseState As DIMOUSESTATE, yRot As D3DVECTOR

    Mk3d.diDeviceMouse.GetDeviceStateMouse MouseState
    yRot.x = MouseState.y * 6.283 / PixelPer360
    yRot.y = MouseState.x * 6.283 / PixelPer360
    yAngle.x = yAngle.x - yRot.x
    yAngle.y = yAngle.y - yRot.y
    If yAngle.x > 1 Then yAngle.x = 1
    If yAngle.x < -1 Then yAngle.x = -1
    If yAngle.y > 6.283 Then yAngle.y = yAngle.y - 6.283
    If yAngle.y < 0 Then yAngle.y = yAngle.y + 6.283
    
    If MGHoldingState = MG_NORMAL Or MGHoldingState = MG_FIRE Then
        If Not MouseState.buttons(0) = 0 And MGHoldingState = MG_NORMAL Then
            MGHoldingState = MG_FIRE
            'start playing the MG sound
            dsShootSound.SetCurrentPosition 0
            dsShootSound.Play DSBPLAY_LOOPING
        ElseIf MouseState.buttons(0) = 0 Then
            MGHoldingState = MG_NORMAL
            Mk3d.LightSetState MGHoldingLightIndex, False
            yEyes.y = EyesHeight
            'stop playing the MG sound
            dsShootSound.Stop
        End If
    End If
End Sub


Private Sub GameMG()
    Dim MGRot As D3DVECTOR
    
    MGWaitT = MGWaitT + FrameT
    MGRot.y = 6.283 * FrameT / MGTimePer360
    MG.Rotate MGRot
    MGAngle.y = MGAngle.y + MGRot.y
End Sub


Private Sub GameMGHolding(MGHoldingRefer As D3DVECTOR, yLookDir As D3DVECTOR, FrCnt As Long)
    Dim MGHoldingLookDir As D3DVECTOR, Corrx!, NewMGPos As D3DVECTOR
    Dim MGPatronState As MGPatronHitEnum, MGPatronPos As D3DVECTOR, MGPatronPosBef As D3DVECTOR
    Dim RdLight As D3DLIGHT7, RdLightStat As Boolean

    If MGHoldingState = MG_NONE Then                       'take MG
        If InArea(yPos, MGPos, 1) And MGWaitT > MGCollT Then
            MGPatrons = 100
            MGWaitT = 0
            MGHoldingUseT = 0
            MGHoldingState = MG_BLENDIN
            NewMGPos = GetRandomPos
            MGPos = Mk3d.VectorMake(NewMGPos.x, MGPos.y, NewMGPos.z)
            MG.MoveTo MGPos
        End If
        Exit Sub
    End If
    
    MGHoldingUseT = MGHoldingUseT + FrameT
    MGPatronsWaitT = MGPatronsWaitT + FrameT
    If MGPatronsWaitT > 1 / MGPatronsShowPerSec Then MGPatronsWaitT = 0
    
    If MGHoldingState = MG_BLENDIN Then
        If MGHoldingUseT < MGLoadT Then
            Corrx = MGLoadDiff - MGHoldingUseT / MGLoadT * MGLoadDiff
        Else
            MGHoldingState = MG_NORMAL
        End If
    ElseIf MGHoldingState = MG_BLENDOUT Then
        If MGHoldingUseT < MGLoadT Then
            'stop playing the sound
            dsShootSound.Stop
            Corrx = MGHoldingUseT / MGLoadT * MGLoadDiff
        Else
            MGHoldingState = MG_NONE
            Exit Sub
        End If
    ElseIf MGHoldingState = MG_FIRE Then
        'turn the the light source of the MG on and off
        RdLight = MGHolding.GetLight(0)
        RdLight.Position = MGHoldingPos
        If FrCnt Mod 2 = 0 Then
            yEyes.y = EyesHeight + 0.05
            RdLightStat = True
        Else
            yEyes.y = EyesHeight
        End If
        Mk3d.LightUpdate MGHoldingLightIndex, RdLight
        Mk3d.LightSetState MGHoldingLightIndex, RdLightStat
        
        If Not Int(MGPatrons) = 0 Then
            'count down the bullets
            MGPatrons = MGPatrons - MGPatronsPerSec * FrameT
            If Int(MGPatrons) <= 0 Then
                MGHoldingState = MG_BLENDOUT
                MGHoldingUseT = 0
                MGPatrons = 0
            Else
                'show the patrons and subtract some points for shooting with the MG