frmludovel5.frm

用VB开发的与跑跑卡丁车一模一样的赛车游戏

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   0  'None
   ClientHeight    =   4770
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   6420
   BeginProperty Font 
      Name            =   "Comic Sans MS"
      Size            =   72
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   ScaleHeight     =   318
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   428
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   WindowState     =   2  'Maximized
   Begin VB.PictureBox Pic 
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      ForeColor       =   &H00FFFFFF&
      Height          =   6855
      Left            =   0
      ScaleHeight     =   457
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   665
      TabIndex        =   0
      Top             =   0
      Width           =   9975
      Begin VB.Timer Tmr_time 
         Enabled         =   0   'False
         Interval        =   1000
         Left            =   120
         Top             =   240
      End
      Begin VB.Label Label1 
         BackColor       =   &H80000012&
         Caption         =   "载入中..."
         BeginProperty Font 
            Name            =   "黑体"
            Size            =   24
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FFFFFF&
         Height          =   495
         Left            =   1920
         TabIndex        =   1
         Top             =   2040
         Width           =   2775
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Option Explicit
Const pi = 3.14159265358979

Private WithEvents RM_E As BDirectx
Attribute RM_E.VB_VarHelpID = -1

Dim RMC As New BDirectx
Dim running As Boolean

Dim Sfondo As Direct3DRMTexture3

Dim scene As Direct3DRMFrame3
Dim cam As Direct3DRMFrame3
Dim mesh As Direct3DRMMeshBuilder3
Dim wallpos As D3DVECTOR
Dim LightFrame As Direct3DRMFrame3
Dim ViewFrame() As Direct3DRMFrame3
Dim Wall(111) As Direct3DRMMeshBuilder3
Dim m_objectFrame(11) As Direct3DRMFrame3
Dim m_meshBuilder(11) As Direct3DRMMeshBuilder3
Dim ombreFrame As Direct3DRMFrame3
Dim ombreMesh As Direct3DRMMeshBuilder3

Dim BonusFrame() As Direct3DRMFrame3
Dim BonusMesh() As Direct3DRMMeshBuilder3

Dim XFileTex As Direct3DRMTexture3

Dim Dir As D3DVECTOR
Dim up As D3DVECTOR
Dim pos As D3DVECTOR

Dim Playersnd As DirectSoundBuffer
Dim Playersnd3D As DirectSound3DBuffer
Dim Driversnd(10) As DirectSoundBuffer
Dim Driversnd3D(10) As DirectSound3DBuffer
Dim Boingsnd As DirectSoundBuffer
Dim Boingsnd3D As DirectSound3DBuffer
Dim Beepsnd As DirectSoundBuffer
Dim Beepsnd3D As DirectSound3DBuffer
Dim Hit1snd As DirectSoundBuffer
Dim Hit1snd3D As DirectSound3DBuffer
Dim Hit2snd As DirectSoundBuffer
Dim Hit2snd3D As DirectSound3DBuffer
Dim Bonussnd As DirectSoundBuffer
Dim Bonussnd3D As DirectSound3DBuffer

Dim D3Pos As D3DVECTOR  ' Holds position of player
Dim D3Ori As D3DVECTOR  ' Holds orientation of player
Dim D3Nor As D3DVECTOR  ' Holds normal of player
Dim Heading As Single      ' Current heading in radians
Dim I_nBanking As Single
Dim Velocity As Single     ' Current velocity
Dim MaxVel As Single       ' Velocity max

Dim TCase As Integer
Dim collide As Boolean, distance As Single
Dim SystemFrame As Single, old As Single, oldtime As Single
Dim vel As Single, nvel As Integer, bp, lv As Single
Dim avanti As Boolean, indietro As Boolean, destra As Boolean, sinistra As Boolean, fine As Boolean, retro As Boolean

Dim xx As Integer, yy As Integer
Dim iFree As Integer
Dim x As Integer
Dim y As Integer
Dim MapNumber As Integer
Dim MapSizeX As Integer
Dim MapSizeY As Integer
Dim StartX As Integer
Dim StartY As Integer
Dim tile() As String
Dim map() As Integer

Dim DINPUT As DirectInput
Dim DIdevice As DirectInputDevice
Dim mat As Direct3DRMMaterial2
Dim keyb As DIKEYBOARDSTATE

Dim dds As DDSURFACEDESC2

Dim t1 As Long, fogcolor As Single
Dim Starttick As Long, LastTick As Long
Dim D3Ray As D3DRMRAY                ' Ray for picking
Dim L_oD3PDA As Direct3DRMPick2Array ' Result of picking
Dim D3PD As D3DRMPICKDESC2           ' Result of picking
Dim L_oD3Visual As Direct3DRMVisual  ' Visual picked
Dim L_bColliding As Boolean
Dim D3Tmp As D3DVECTOR

Dim oview As Single, hview As Single, dview As Single
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Private Type RacerType
    Name        As String
    Location_X  As Single
    Location_Z  As Single
    Direction   As Single
    Speed       As Single
    MaxSpeed    As Single
    MinSpeed    As Single
    TurnRatio   As Single   'We rotate this much every tick
    Acceleration As Single
    BrakeSpeed  As Single
    BackAngle   As Single   'Used in speed calculations, see tutorial for proper explanation
    Radius      As Integer  'The size of the car
    NextNode    As Integer  'The number of the node we're heading for
    Lap         As Integer
    time        As String
    Position    As Integer
End Type

Private Type NodeType
    Location_X  As Single
    Location_Y  As Single
    Dir As String
End Type

Private Type TargetType
    Location_X  As Single
    Location_Z  As Single
    Pass As Boolean
    Size As Integer
End Type

Private Type bonusType
    Location_X  As Single
    Location_Z  As Single
    Active As Boolean
    sec As Integer
End Type

Private Racers(10) As RacerType   'Opponent racers
Private DummyRacers(10) As RacerType
Private Racerspos(10) As Byte

Private Nodes() As NodeType      'An array of nodes marking our route
Private Targets() As TargetType
Private Bonus() As bonusType

Private Const NodeRadius = 15    'Size of the nodes
            
Private CircleX As Single        'They would be local vars except
Private CircleY As Single
Private CircleRadius As Single

Dim ArrNum15() As Integer, ret As Integer
Dim TargetsCount As Integer, Lap As Integer
Dim Numdown As Integer, MyFont As New StdFont, cont As Byte
Dim Timemin As Single, Timesec As Single, Besttime As String
Dim F1 As Boolean, F2 As Boolean, F3 As Boolean, F4 As Boolean, F5 As Boolean, F6 As Boolean
Dim F7 As Boolean, F8 As Boolean, F9 As Boolean, F10 As Boolean, F11 As Boolean, F12 As Boolean

Dim Lastnodes As Boolean

'Main sub
Public Sub form_load()
Dim ind As Integer

MusicVolume = 75 'Max(100%) -> MusicVolume = 100
                 'High      -> MusicVolume = 75
                 'Medium    -> MusicVolume = 50
                 'Low       -> MusicVolume = 25
                 'Null(0%)  -> MusicVolume = 0
'Set music
Music_mod.Initialize_Music
Music_mod.Load_Music (0)
Music_mod.SetMusic (MusicVolume)

Me.Show

Pic.ScaleWidth = frmMain.ScaleWidth
Pic.ScaleHeight = frmMain.ScaleHeight
Label1.left = (frmMain.ScaleWidth - Label1.Width) / 2
Label1.top = (frmMain.ScaleHeight - Label1.Height) / 2

DoEvents

    ShowCursor 0
    TCase = 60
    Set RM_E = RMC
    RMC.hwnd = Pic.hwnd
    RMC.UseBackBuffer = True
    RMC.Use3DHardware = True
    RMC.StartWindowed
    InitDeviceobjects
    InitSounds
    
    Set DINPUT = RMC.dx.DirectInputCreate
    Set DIdevice = DINPUT.CreateDevice("GUID_SysKeyboard")
    DIdevice.SetCommonDataFormat DIFORMAT_KEYBOARD
    DIdevice.SetCooperativeLevel Me.hwnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
     
    ' Create rotating background
    dds.lFlags = DDSD_WIDTH Or DDSD_HEIGHT
    dds.lHeight = RMC.Viewport.GetHeight  '/ 2  + 12
    dds.lWidth = RMC.Viewport.GetWidth * 5 / 2
    'I don't have downloaded the original background (too big)
    Set Background = RMC.DDraw.CreateSurfaceFromFile(App.path & "\back.bmp", dds)
  
    Initwalls
    OpenMap
    CreatePlayers
    
    For ind = 1 To UBound(Racers)
        RandNum
    Next
    InitRacers
    
    doTargets
    
    nvel = 0
    Angle = 0
    Heading = 0
    Velocity = 0
    MaxVel = 6
    hview = 5
    dview = -25
    cont = 1
    Lastnodes = False
    
    F1 = False
    F2 = False
    F3 = False
    F4 = False
    F5 = False
    F6 = False
    F7 = False
    F8 = False
    F9 = False
    F10 = False

    running = True
    Numdown = 0
    Lap = 1
    
    Timemin = 0
    Timesec = 0
    
    dview = -50
    
    Music_mod.PlayMusic
    
    ' main loop
    Do While running = True
       SystemFrame = RMC.dx.TickCount - oldtime
       oldtime = RMC.dx.TickCount
       If oldtime > old + 1000 Then
          old = oldtime
          If Tmr_time.Enabled = False Then Numdown = Numdown + 1
          For ind = 1 To UBound(Bonus)
              If Bonus(ind).Active = False Then
                 Bonus(ind).sec = Bonus(ind).sec + 1
                 If Bonus(ind).sec > 5 Then
                    Bonus(ind).sec = 0
                    Bonus(ind).Active = True
                    If BonusFrame(ind).GetVisualCount = 0 Then BonusFrame(ind).AddVisual BonusMesh(ind)
                 End If
              End If
          Next
       End If
       If Lap = 1 And dview < -25 Then dview = dview + 0.5
       If Numdown <= 4 Then '3,2,1,GO!
          m_objectFrame(1).SetPosition Nothing, StartX * TCase, 2, StartY * TCase
          ombreFrame.SetPosition m_objectFrame(1), 0, -1.95, 0
          RMC.CameraFrame.SetPosition m_objectFrame(1), 0, hview, dview
          RMC.CameraFrame.LookAt m_objectFrame(1), Nothing, D3DRMCONSTRAIN_Z
          For ind = 1 To UBound(Racers)
              m_objectFrame(ind + 1).SetPosition Nothing, Racers(ind).Location_X, 1, Racers(ind).Location_Z
          Next
          If Numdown = 4 Then Tmr_time.Enabled = True