frmludovel5.frm

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

ombreFrame.AddVisual ombreMesh
Set ombreMesh = Nothing
    
m_objectFrame(1).SetPosition RMC.SceneFrame, StartX * TCase, 2, StartY * TCase
ombreFrame.SetPosition RMC.SceneFrame, StartX * TCase, 0.1, StartY * TCase

End Sub
Private Sub RandNum()
' Random routine for 5 numbers
Static count As Integer, i As Integer
Dim intNum As Integer
count = count + 1
If count > UBound(Racers) Then
    count = 1
    Exit Sub
End If
ReDim Preserve ArrNum15(1 To UBound(Racers))
Randomize
intNum = Int((UBound(Racers) * Rnd) + 1)
                             
If count > 1 Then

    For i = 1 To count - 1
        Do Until ArrNum15(i) < intNum
            If ArrNum15(i) = intNum Then
               intNum = Int((UBound(Racers) * Rnd) + 1)
               i = 1
            Else
               Exit Do
            End If
        Loop
    Next i
End If
ArrNum15(count) = intNum
End Sub
Private Sub InitRacers()
Dim i As Integer, rand As Integer

For i = 1 To UBound(Racers)
    Racers(i).Radius = 2.5
    Racers(i).Acceleration = 0.25
    Racers(i).BrakeSpeed = 1
    Racers(i).Direction = 0
    Racers(ArrNum15(i)).Speed = (i + 1) * 0.05
    Racers(i).MaxSpeed = 8
    Racers(i).MinSpeed = 1
    Racers(ArrNum15(i)).TurnRatio = (i + 1) * 0.05
    If Racers(ArrNum15(i)).TurnRatio > 0.3 Then Racers(ArrNum15(i)).TurnRatio = 0.3
    Racers(i).BackAngle = pi / 3 '* 2
    Racers(i).NextNode = 1
    Racers(i).Lap = 1
    Racers(i).time = 0
Next

Racers(1).Name = "KAZIM 1"
Racers(1).Location_X = 6.9 * TCase
Racers(1).Location_Z = 2 * TCase
Racers(1).Position = 3
Racers(2).Name = "KAZIM 2"
Racers(2).Location_X = 6.8 * TCase
Racers(2).Location_Z = 1.6 * TCase
Racers(2).Position = 5
Racers(3).Name = "COP 1"
Racers(3).Location_X = 6.7 * TCase
Racers(3).Location_Z = 2.2 * TCase
Racers(3).Position = 10
Racers(4).Name = "COP 2"
Racers(4).Location_X = 6.9 * TCase
Racers(4).Location_Z = 1.8 * TCase
Racers(4).Position = 1
Racers(5).Name = "IRON 1"
Racers(5).Location_X = 6.9 * TCase
Racers(5).Location_Z = 2.1 * TCase
Racers(5).Position = 2
Racers(6).Name = "IRON 2"
Racers(6).Location_X = 6.7 * TCase
Racers(6).Location_Z = 1.9 * TCase
Racers(6).Position = 9
Racers(7).Name = "LEROY 1"
Racers(7).Location_X = 6.8 * TCase
Racers(7).Location_Z = 1.8 * TCase
Racers(7).Position = 6
Racers(8).Name = "LEROY 2"
Racers(8).Location_X = 6.9 * TCase
Racers(8).Location_Z = 2.3 * TCase
Racers(8).Position = 4
Racers(9).Name = "CUBIK 1"
Racers(9).Location_X = 6.7 * TCase
Racers(9).Location_Z = 1.7 * TCase
Racers(9).Position = 8
Racers(10).Name = "CUBIK 2"
Racers(10).Location_X = 6.8 * TCase
Racers(10).Location_Z = 2.1 * TCase
Racers(10).Position = 7

End Sub
Private Sub OpenMap()
Dim campo, rot As Byte, num As Integer, nodi As Integer, ind As Integer
    
       iFree = FreeFile
       Open App.path & "\mappa1.map" For Input As #iFree
       Input #iFree, MapNumber, MapSizeX, MapSizeY, StartX, StartY
    
       'resize and clear out the map arrays
       ReDim map(MapSizeX, MapSizeY)
       ReDim ViewFrame(MapSizeX, MapSizeY)
       ReDim tile(MapSizeX, MapSizeY)
    
       For xx = 0 To MapSizeX - 1
           For yy = 0 To MapSizeY - 1
               Input #iFree, tile(xx, yy)
               num = CInt(Mid(tile(xx, yy), 1, 3))
               rot = CInt(Mid(tile(xx, yy), 4, 1))
               Set ViewFrame(xx, yy) = RMC.D3DRM.CreateFrame(RMC.SceneFrame)
               With ViewFrame(xx, yy)
                    .AddScale D3DRMCOMBINE_REPLACE, 0.5, 0.5, 0.5
                    .SetPosition RMC.SceneFrame, xx * 60, 0, yy * 60
                    If rot = 1 Then .AddRotation D3DRMCOMBINE_BEFORE, 0, 1, 0, 0 * (pi / 180)
                    If rot = 2 Then .AddRotation D3DRMCOMBINE_BEFORE, 0, 1, 0, 90 * (pi / 180)
                    If rot = 3 Then .AddRotation D3DRMCOMBINE_BEFORE, 0, 1, 0, 180 * (pi / 180)
                    If rot = 4 Then .AddRotation D3DRMCOMBINE_BEFORE, 0, 1, 0, 270 * (pi / 180)
                    .AddVisual Wall(num)
               End With
           Next yy
           Input #iFree, campo
       Next xx
       
      Input #iFree, num
    
      ReDim BonusFrame(num)
      ReDim BonusMesh(num)
      ReDim Bonus(num)
      For ind = 1 To num
          Input #iFree, xx, yy
          Set BonusFrame(ind) = RMC.D3DRM.CreateFrame(RMC.SceneFrame)
          Set BonusMesh(ind) = RMC.D3DRM.CreateMeshBuilder()
          BonusMesh(ind).LoadFromFile App.path & "\Mesh\bonus.x", 0, D3DRMLOAD_FROMFILE, Nothing, Nothing
          BonusFrame(ind).AddScale D3DRMCOMBINE_REPLACE, 1, 1, 1
          BonusFrame(ind).SetPosition RMC.SceneFrame, xx * TCase, 0, yy * TCase
          Bonus(ind).Location_X = xx * TCase
          Bonus(ind).Location_Z = yy * TCase
          Bonus(ind).Active = True
          Bonus(ind).sec = 0
          BonusFrame(ind).AddVisual BonusMesh(ind)
       Next
       
       Close #iFree
       
       Open App.path & "\path.map" For Input As #iFree
       Input #iFree, nodi
       ReDim Nodes(nodi)
       For ind = 1 To nodi
           Input #iFree, Nodes(ind).Location_X, Nodes(ind).Location_Y, Nodes(ind).Dir
           Nodes(ind).Location_X = Nodes(ind).Location_X * TCase
           Nodes(ind).Location_Y = Nodes(ind).Location_Y * TCase
       Next
       Close #iFree
    
End Sub
Private Sub pic_KeyDown(KeyCode As Integer, Shift As Integer)
 Select Case KeyCode
    Case vbKeyUp: avanti = True
    Case vbKeyDown: indietro = True
    Case vbKeyLeft: sinistra = True
    Case vbKeyRight: destra = True
    Case vbKeyEscape: fine = True
    Case vbKeyV: retro = True: If ret = 0 Then ret = 1 Else ret = 2
    Case vbKeyF1: F1 = True
    Case vbKeyF2: F2 = True
    Case vbKeyF3: F3 = True
    Case vbKeyF4: F4 = True
    Case vbKeyF5: F5 = True
    Case vbKeyF6: F6 = True
    Case vbKeyF7: F7 = True
    Case vbKeyF8: F8 = True
    Case vbKeyF9: F9 = True
    Case vbKeyF10: F10 = True
    Case vbKeyF11: F11 = True
    Case vbKeyF12: F12 = True
 
 End Select
End Sub
Private Sub pic_KeyUp(KeyCode As Integer, Shift As Integer)
  Select Case KeyCode
    Case vbKeyUp: avanti = False
    Case vbKeyDown: indietro = False
    Case vbKeyLeft: sinistra = False
    Case vbKeyRight: destra = False
    Case vbKeyEscape: fine = False
    Case vbKeyV: retro = False: ret = 0
    Case vbKeyF1: F1 = False
    Case vbKeyF2: F2 = False
    Case vbKeyF3: F3 = False
    Case vbKeyF4: F4 = False
    Case vbKeyF5: F5 = False
    Case vbKeyF6: F6 = False
    Case vbKeyF7: F7 = False
    Case vbKeyF8: F8 = False
    Case vbKeyF9: F9 = False
    Case vbKeyF10: F10 = False
    Case vbKeyF11: F11 = False
    Case vbKeyF12: F12 = False
  
  End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    running = False
    Cleanup
End Sub
Private Sub Form_Resize()
    Pic.Width = Me.ScaleWidth
    Pic.Height = Me.ScaleHeight
    If running = False Then Exit Sub
    If RMC.IsFullScreen = True Then Exit Sub
    RMC.Resize Pic.ScaleWidth, Pic.ScaleHeight
End Sub
Private Sub InitDeviceobjects()
Dim fogcolor
fogcolor = 0 * 65536 + 125 * 256 + 125

    Dim vp As Direct3DRMViewport2
    Set vp = RMC.Viewport
    vp.SetBack 1000
    vp.SetFront 1
    vp.SetProjection D3DRMPROJECT_PERSPECTIVE
    
    Set mat = RMC.D3DRM.CreateMaterial(0)
    With mat
        .SetAmbient 1, 1, 1
    End With
    
    RMC.SceneFrame.SetSceneBackground fogcolor
    RMC.SceneFrame.SetSceneFogEnable D_TRUE
    RMC.SceneFrame.SetSceneFogMethod D3DRMFOGMETHOD_TABLE
    RMC.SceneFrame.SetSceneFogColor fogcolor
    RMC.SceneFrame.SetSceneFogMode D3DRMFOG_LINEAR
    RMC.SceneFrame.SetSceneFogParams 520, 1000, 1
    
    With RMC.Device
        .SetTextureQuality D3DRMTEXTURE_LINEARMIPLINEAR
        .SetQuality D3DRMFILL_SOLID Or D3DRMLIGHT_ON Or D3DRMRENDER_GOURAUD Or D3DRMSHADE_GOURAUD
        .SetDither D_TRUE
        .SetRenderMode D3DRMRENDERMODE_BLENDEDTRANSPARENCY Or D3DRMRENDERMODE_SORTEDTRANSPARENCY
    End With
    
    RMC.AmbientLight.SetColorRGB 255, 255, 255
    RMC.DirLight.SetType D3DRMLIGHT_POINT
    RMC.DirLightFrame.SetPosition Nothing, 1 * TCase, 10 * TCase, 1 * TCase
    
End Sub
Private Sub RM_E_DirecXNotInstalled()
    MsgBox "DirectX7 is not installed", vbCritical
    End
End Sub
Private Sub RM_E_Error4(Errstr As String)
    MsgBox Errstr, vbCritical, "Error"
    End
End Sub
Private Sub RM_E_PostRender()
Dim i As Integer, Annuncio As String
    
    On Local Error Resume Next
       If Numdown < 4 Then
          MyFont.Name = "Comic Sans MS"
          MyFont.Size = 200
          MyFont.Bold = True
          RMC.BackBuffer.SetFont MyFont
          RMC.BackBuffer.SetForeColor RGB(255, 255, 255)
       End If
       If Numdown = 1 Then RMC.BackBuffer.DrawText (frmMain.ScaleWidth - 200) / 2, (frmMain.ScaleHeight - 400) / 2, "3", False
       If Numdown = 2 Then RMC.BackBuffer.DrawText (frmMain.ScaleWidth - 200) / 2, (frmMain.ScaleHeight - 400) / 2, "2", False
       If Numdown = 3 Then RMC.BackBuffer.DrawText (frmMain.ScaleWidth - 200) / 2, (frmMain.ScaleHeight - 400) / 2, "1", False
       If Numdown = 4 Then RMC.BackBuffer.DrawText (frmMain.ScaleWidth - 350) / 2, (frmMain.ScaleHeight - 400) / 2, "GO!", False
       If Numdown > 4 And Lap < 4 Then
          MyFont.Name = "Impact"
          MyFont.Size = 15
          MyFont.Bold = True
          RMC.BackBuffer.SetFont MyFont
          RMC.BackBuffer.SetForeColor RGB(255, 255, 255)  'vbWhite
          RMC.BackBuffer.DrawText 20, frmMain.ScaleHeight - 30, "速度: " + CStr(CInt(Velocity)), False
          RMC.BackBuffer.DrawText (frmMain.ScaleWidth - 20) / 2, frmMain.ScaleHeight - 30, "时间: " + CStr(Format(Timemin, "00")) + "." & CStr(Format(Timesec, "00")), False
          RMC.BackBuffer.DrawText (frmMain.ScaleWidth - 100), frmMain.ScaleHeight - 30, "圈数: " + CStr(Lap) & "/3", False
       End If
       If Lap > 3 Then
          For i = 1 To UBound(Racers)
              If Racers(i).Position = 1 Then
                 If Racers(i).Lap = 4 And Racers(i).time < CStr(Format(Timemin, "00")) + CStr(Format(Timesec, "00")) Then
                    Annuncio = "WINNER IS " & CStr(Racers(i).Name)
                    Besttime = CStr(Mid(Racers(i).time, 1, 2)) & "." & CStr(Mid(Racers(i).time, 3, 2))
                 Else
                    Annuncio = "   WINNER IS YOU"
                    Besttime = CStr(Format(Timemin, "00")) + "." & CStr(Format(Timesec, "00"))
                 End If
              End If
          Next
          
          MyFont.Name = "Comic Sans MS"
          MyFont.Size = 50
          MyFont.Bold = True
          RMC.BackBuffer.SetFont MyFont
          RMC.BackBuffer.SetForeColor RGB(255, 255, 255)
          RMC.BackBuffer.DrawText 120, (frmMain.ScaleHeight - 400) / 2, Annuncio, False
          MyFont.Size = 20
          RMC.BackBuffer.DrawText 200, (frmMain.ScaleHeight - 400) / 2 + 150, "Best Time: " + Besttime, False
          RMC.BackBuffer.DrawText 200, (frmMain.ScaleHeight - 400) / 2 + 250, "Your Time: " + CStr(Format(Timemin, "00")) + "." & CStr(Format(Timesec, "00")), False
          MyFont.Name = "Impact"
          MyFont.Size = 15
          MyFont.Bold = True
          RMC.BackBuffer.SetFont MyFont
          RMC.BackBuffer.SetForeColor RGB(255, 255, 255)
          RMC.BackBuffer.DrawText (frmMain.ScaleWidth - 20) / 2, frmMain.ScaleHeight - 30, "Press ESC to Quit", False
       
       End If
'       RMC.BackBuffer.DrawText 10, 10, "Frame/Sec:" + CStr(RMC.FPS), False
End Sub
Private Sub Cleanup()
Dim i As Integer, j As Integer
For i = 0 To MapSizeX - 1
    For j = 0 To MapSizeY - 1
        Set ViewFrame(i, j) = Nothing
    Next j
Next i
For i = 0 To 111
    Set Wall(i) = Nothing
Next i
Set ombreFrame = Nothing
For i = 1 To UBound(Racers) + 1
    Set m_objectFrame(i) = Nothing
    Set m_meshBuilder(i) = Nothing
Next i

Music_mod.EndMusic

Set Playersnd = Nothing
Set Playersnd3D = Nothing
For i = 1 To UBound(Racers)
    Set Driversnd(i) = Nothing
    Set Driversnd3D(i) = Nothing
Next i
Set Boingsnd = Nothing