rabit/RaBit%27s%20Rapid%20Racers/Form_D3D.frm

VERSION 5.00
Begin VB.Form Form_D3D 
   BorderStyle     =   5  'Sizable ToolWindow
   Caption         =   "RRR"
   ClientHeight    =   7200
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9600
   ClipControls    =   0   'False
   FillStyle       =   0  'Solid
   BeginProperty Font 
      Name            =   "Terminal"
      Size            =   6
      Charset         =   255
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   KeyPreview      =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   480
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   640
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox Picture_TrackMap 
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ClipControls    =   0   'False
      FillStyle       =   0  'Solid
      ForeColor       =   &H80000008&
      Height          =   6000
      Left            =   0
      ScaleHeight     =   400
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   400
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   6000
   End
End
Attribute VB_Name = "Form_D3D"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'

Public Function Initialise() As Boolean

Dim lAdapter As Long
Dim lD3DCreateFlags As CONST_D3DCREATEFLAGS

Dim fcDevCaps As D3DCAPS8

Dim matProjection As D3DMATRIX
    
    lAdapter = D3DADAPTER_DEFAULT

    On Error GoTo ErrHandler

    ConPrint Const_strConsoleBlockTitlePre + "testing device features:" + Const_strConsoleBlockTitlePost
    ConPrint "  " & clSystem.D3D8.GetAdapterCount & " display adapter(s) found.[brk][brk]"
    
    With tpD3DPresentParameters
    
        If Form_Start.Check_Windowed.Value = 1 Then
        
            clSystem.D3D8.GetAdapterDisplayMode lAdapter, tpUsedDispMode
        
            .BackBufferCount = 1
            .BackBufferFormat = tpUsedDispMode.Format
        
            .Windowed = 1

        Else
        
            clSystem.D3D8.EnumAdapterModes 0, Form_Start.Combo_RefreshRate.ItemData(Form_Start.Combo_RefreshRate.ListIndex), tpUsedDispMode
        
            .BackBufferCount = 1
            .BackBufferFormat = tpUsedDispMode.Format
            .BackBufferWidth = tpUsedDispMode.Width
            .BackBufferHeight = tpUsedDispMode.Height
            .FullScreen_RefreshRateInHz = tpUsedDispMode.RefreshRate
'            .FullScreen_PresentationInterval = 0
            
        End If
        
        .hDeviceWindow = Form_D3D.hWnd

        .AutoDepthStencilFormat = D3DFMT_D16
        .EnableAutoDepthStencil = 1

'        .SwapEffect = D3DSWAPEFFECT_FLIP
        
        If Form_Start.Check_Antialias.Value = 1 Then
        
            .SwapEffect = D3DSWAPEFFECT_DISCARD
            
            If Form_Start.Option_MultisampleType2.Value = True Then
            
                If clSystem.D3D8.CheckDeviceMultiSampleType(lAdapter, D3DDEVTYPE_HAL, D3DFMT_R8G8B8, .Windowed, D3DMULTISAMPLE_2_SAMPLES) Then .MultiSampleType = D3DMULTISAMPLE_2_SAMPLES
            
            ElseIf Form_Start.Option_MultisampleType4.Value = True Then
            
                If clSystem.D3D8.CheckDeviceMultiSampleType(lAdapter, D3DDEVTYPE_HAL, D3DFMT_R8G8B8, .Windowed, D3DMULTISAMPLE_4_SAMPLES) Then .MultiSampleType = D3DMULTISAMPLE_4_SAMPLES
    
            End If
    
        Else
        
            .SwapEffect = D3DSWAPEFFECT_COPY '_VSYNC
        
        End If
    
        If .MultiSampleType > D3DMULTISAMPLE_NONE Then
        
            ConPrint "  antialiasing type is [c02]" & .MultiSampleType & "x multisampling[c07].[brk]"
        
        Else
        
            ConPrint "  antialiasing is [c12]deactivated[c07].[brk]"
        
        End If
        
    End With
    
    '############################
    '## CHECK THE DEVICE CAPABILITIES ##
    '###########################
    
    On Local Error Resume Next
        
    clSystem.D3D8.GetDeviceCaps lAdapter, D3DDEVTYPE_HAL, fcDevCaps
    
    If Err.Number = D3DERR_INVALIDDEVICE Then
        
        'We couldn't get data from the hardware device - probably doesn't exist...
        clSystem.D3D8.GetDeviceCaps lAdapter, D3DDEVTYPE_REF, fcDevCaps
        Err.Clear ' Remove the error value..
    
    End If
    
    ConPrint "  hardware transform and lighting... "
    
    '...for Hardware vertex processing:
    If (fcDevCaps.DevCaps And D3DDEVCAPS_HWTRANSFORMANDLIGHT) Then
        
        lD3DCreateFlags = D3DCREATE_HARDWARE_VERTEXPROCESSING
        ConPrint Const_strConsoleTextOK
        
    Else
        
        lD3DCreateFlags = D3DCREATE_SOFTWARE_VERTEXPROCESSING
        ConPrint Const_strConsoleTextFail
    
    End If
    
    ConPrint "  pure device support... "
    
    '...for Pure Device processing:
    If (fcDevCaps.DevCaps And D3DDEVCAPS_PUREDEVICE) Then
        
        lD3DCreateFlags = lD3DCreateFlags Or D3DCREATE_PUREDEVICE
        ConPrint Const_strConsoleTextOK
    
    Else
        
        ConPrint Const_strConsoleTextFail
    
    End If
    
Dim fcPRasterCapsFlags As CONST_D3DPRASTERCAPSFLAGS

    fcPRasterCapsFlags = fcDevCaps.RasterCaps

    ConPrint "  colour dithering... "
    
    If (fcPRasterCapsFlags And D3DPRASTERCAPS_DITHER) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail
    
    fcPRasterCapsFlags = fcDevCaps.RasterCaps

    ConPrint "  anisotropic filtering... "
    
    If (fcPRasterCapsFlags And D3DPRASTERCAPS_ANISOTROPY) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail

    ConPrint "  edge antialiasing... "
    
    If (fcPRasterCapsFlags And D3DPRASTERCAPS_ANTIALIASEDGES) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail

    ConPrint "  range-based fog... "
    
    If (fcPRasterCapsFlags And D3DPRASTERCAPS_FOGRANGE) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail

    ' This line creates a device that uses a hardware device if possible; software vertex processing and uses the form as it's target
    Set clD3DDevice = clSystem.D3D8.CreateDevice(lAdapter, D3DDEVTYPE_HAL, Form_D3D.hWnd, lD3DCreateFlags, tpD3DPresentParameters)
                                                            
    ' Configure the rendering device
    clD3DDevice.SetVertexShader Const_lFVF_Vertex '//Tell it what type of vertex we are using
    clD3DDevice.SetRenderState D3DRS_LIGHTING, 1  '//Enable lighting.
    clD3DDevice.SetRenderState D3DRS_ZENABLE, 1
    clD3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE

    If tpD3DPresentParameters.MultiSampleType > 0 Then clD3DDevice.SetRenderState D3DRS_MULTISAMPLE_ANTIALIAS, 1

'    clD3DDevice.SetRenderState D3DRS_ALPHABLENDENABLE, 1
'    clD3DDevice.SetRenderState D3DRS_RANGEFOGENABLE, 1
    
'    clD3DDevice.SetRenderState D3DRS_DITHERENABLE, True
'    clD3DDevice.SetRenderState D3DRS_EDGEANTIALIAS, True
'    clD3DDevice.SetRenderState D3DRS_SPECULARENABLE, True
'    clD3DDevice.SetRenderState D3DRS_FOGENABLE, True
    
    '//configure the world matrices
    
    '//1. The World Matrix
'    D3DXMatrixIdentity matWorld
    clD3DDevice.SetTransform D3DTS_WORLD, tpMatIdentity 'commit this matrix to the device
    
    '//3. The projection Matrix
    D3DXMatrixPerspectiveFovLH matProjection, 0.3 * Const_sgPi, tpUsedDispMode.Height / tpUsedDispMode.Width, 0.1, 300
    clD3DDevice.SetTransform D3DTS_PROJECTION, matProjection

    Initialise = True '//We succeeded
    
    ConPrint "[brk]"
    
    Exit Function
    
ErrHandler:
    
    Initialise = False
    ConPrint "[brk][c03]error returned:[brk]no. " & Err.Number & ": " + Err.Description + "[c15][brk]"

End Function

Public Sub Render()

Dim clCurrentObject As Class_GeoObject
Dim clPlayer As Class_Player

Dim bIsPlayerObject As Boolean

Dim tpMatTemp1 As D3DMATRIX
Dim tpMatTemp2 As D3DMATRIX

Dim l As Long
Dim lPlayerIndex As Long
Dim lVertexCount As Long

Dim tpVecPlayerPosition As D3DVECTOR

    With clD3DDevice

        If Not lplKeyControlFlags(vbKeyQ) Then .Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, clScene.lBackgroundColour, 1#, 0
'        .Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, clScene.lBackgroundColour, 1#, 0
        
'        SetupLighting
        
        .BeginScene
    
'        SetupPixelFog D3DColorXRGB(1#, 1#, 1#), D3DFOG_LINEAR
        
        For l = 1 To clScene.Col_clGeoObjects.Count

            Set clCurrentObject = clScene.Col_clGeoObjects(l)
            
            bIsPlayerObject = LCase(Left(clCurrentObject.strName, 3)) = "pla"
            
            If bIsPlayerObject Then
            
                For lPlayerIndex = 1 To clGame.Col_clPlayers.Count
                
                    Set clPlayer = clGame.Col_clPlayers(lPlayerIndex)
                
                    If bShowPlayer Or clPlayer.lPlayerType <> ePT_LocalHuman Then
    
                        tpMatTemp1 = tpMatIdentity
                        
                        tpVecPlayerPosition = clPlayer.GetPosition
                        
                        D3DXMatrixTranslation tpMatTemp1, clCurrentObject.sgPositionX, -clCurrentObject.sgPositionZ, clCurrentObject.sgPositionY
                        
                        tpMatTemp2 = tpMatIdentity
                        D3DXMatrixRotationY tpMatTemp2, -clPlayer.sgAngleY * Const_sgDeg2Rad
                        D3DXMatrixMultiply tpMatTemp1, tpMatTemp1, tpMatTemp2
        
                        tpMatTemp2 = tpMatIdentity
                        D3DXMatrixTranslation tpMatTemp2, tpVecPlayerPosition.X, tpVecPlayerPosition.Y, tpVecPlayerPosition.Z
                        D3DXMatrixMultiply tpMatTemp1, tpMatTemp1, tpMatTemp2
                        
                        .SetTransform D3DTS_WORLD, tpMatTemp1
                        RenderGeoObject clCurrentObject

                    End If
                
                Next lPlayerIndex

            Else
                
                .SetTransform D3DTS_WORLD, tpMatIdentity
                RenderGeoObject clCurrentObject
                
            End If
    
        Next l

        DrawOverlay
        
        .EndScene
        
        .Present ByVal 0, ByVal 0, 0, ByVal 0

    End With

End Sub

Private Function CheckDisplayMode(Width As Long, Height As Long, Depth As Long) As CONST_D3DFORMAT

Dim i As Long
Dim tpUsedDispMode As D3DDISPLAYMODE
    
    For i = 0 To clSystem.D3D8.GetAdapterModeCount(0) - 1
        
        clSystem.D3D8.EnumAdapterModes 0, i, tpUsedDispMode
        
        If tpUsedDispMode.Width = Width Then
            
            If tpUsedDispMode.Height = Height Then
                
                If tpUsedDispMode.Format = D3DFMT_R5G6B5 Or D3DFMT_X1R5G5B5 Or D3DFMT_X4R4G4B4 Then
                    
                    '16 bit mode
                    If Depth = 16 Then
                        
                        CheckDisplayMode = tpUsedDispMode.Format
                        Exit Function
                    
                    End If
                
                ElseIf tpUsedDispMode.Format = D3DFMT_R8G8B8 Or D3DFMT_X8R8G8B8 Then
                    
                    '32bit mode
                    If Depth = 32 Then
                        
                        CheckDisplayMode = tpUsedDispMode.Format
                        Exit Function
                    
                    End If
            
                End If
            
            End If
        
        End If
    
    Next i

    CheckDisplayMode = D3DFMT_UNKNOWN

End Function

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    If KeyCode = vbKeyEscape Then
    
        If lMenuIndex = 0 Then
        
            lMenuIndex = 1
            lMenuSelectedItem = 0

        Else
        
            lMenuIndex = 0
        
        End If

    ElseIf lMenuIndex = 0 Then
    
'        If KeyCode = vbKeyE Then
'
'            clD3DDevice.SetRenderState D3DRS_LIGHTING, 1  'Enable lighting.
'
'        ElseIf KeyCode = vbKeyD Then
'
'            clD3DDevice.SetRenderState D3DRS_LIGHTING, 0  'Disable lighting.
'
'        ElseIf KeyCode = vbKeyW Then
'
'            clD3DDevice.SetRenderState D3DRS_FILLMODE, D3DFILL_WIREFRAME  'Set wireframe rendering.
'
'        ElseIf KeyCode = vbKeyS Then
'
'            clD3DDevice.SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID  'Set solid rendering.
'
'        Else

        If KeyCode = vbKeyC Then

            lCamMode = lCamMode + 1

            If lCamMode = 6 Then lCamMode = 0

        Else
        
            If lLocalPlayerHandle <> 0 Then
            
                clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags = clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags Or lplKeyControlFlags(KeyCode)
'                Debug.Print clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags
                
            End If

        End If

    Else

        If KeyCode = vbKeyReturn Then
        
Dim lpstrArguments() As String

            lpstrArguments = Split(Col_clMenus(lMenuIndex).Item(lMenuSelectedItem + 1).strCommand, " ")

            If UBound(lpstrArguments) >= 0 Then

                Select Case lpstrArguments(0)
             
                    Case "exit"
    
                        clGame.RemoveAllPlayers
                        DeleteScene
    
                    Case "menu"
    
                        lMenuIndex = Val(lpstrArguments(1))
                        lMenuSelectedItem = 0
                        
                    Case "quit"
             
                        bRunning = False
                        clGame.RemoveAllPlayers
                        DeleteScene
                        
                    Case "single"
    
                        lMenuIndex = 0
                        DoEvents
                        StartSinglePlayerGame

                End Select
            
            End If
        
        ElseIf KeyCode = vbKeyDown Then
        
            lMenuSelectedItem = lMenuSelectedItem + 1
            
            If lMenuSelectedItem >= Col_clMenus(lMenuIndex).Count Then lMenuSelectedItem = 0
         
        ElseIf KeyCode = vbKeyUp Then

            lMenuSelectedItem = lMenuSelectedItem - 1
            
            If lMenuSelectedItem < 0 Then lMenuSelectedItem = Col_clMenus(lMenuIndex).Count - 1
         
        End If

    End If

End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

'    lplKeyControlFlags(KeyCode) = False

    If lLocalPlayerHandle <> 0 Then clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags = clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags And Not lplKeyControlFlags(KeyCode)

End Sub

Private Sub Form_Load()

    Me.Show

    bRunning = Initialise()

    If bRunning Then

        SetupOverlay
        
        SetupKeyCommands
        SetupLighting
        
        If Form_Start.Check_Windowed.Value = 1 Then
        
            tpUsedDispMode.Width = Me.ScaleWidth
            tpUsedDispMode.Height = Me.ScaleHeight
        
        End If
        
        ConPrint Const_strConsoleTextLine + _
          Const_strConsoleTextLineIndent + "[c14]key commands:[c15][brk]" + _
          Const_strConsoleTextLine + _
          Const_strConsoleTextLineIndent + "        up ... accelerate forward[brk]" + _
          Const_strConsoleTextLineIndent + "      down ... accelerate backward[brk]" + _
          Const_strConsoleTextLineIndent + "left/right ... rotate steering wheel[brk]" + _
          Const_strConsoleTextLineIndent + "     space ... break[brk]" + _
          Const_strConsoleTextLineIndent + "     shift ... use horn[brk]" + _
          Const_strConsoleTextLineIndent + "         c ... change camera mode[brk]" + _
          Const_strConsoleTextLineIndent + "       esc ... show/hide menu[brk]" + _
          Const_strConsoleTextLine
          
'          Const_strConsoleTextLineIndent + "       w/s ... wireframe/solid render mode[brk]" + _
'          Const_strConsoleTextLineIndent + "       e/d ... enable/disable lighted shading[brk]" + _

        clSystem.DS8SetCooperativeLevel Form_D3D.hWnd

    End If
    
    MainLoop
    
    On Error Resume Next
    
    Set clD3DDevice = Nothing
'    Set D3D = Nothing
'    Set DX = Nothing
    
'    clDSSoundBuffer1.Stop
'    clDSSoundBuffer2.Stop
'    clDSSoundBuffer3.Stop
    
    Form_Start.Command_Start.Enabled = True
    Unload Me

    End

End Sub

Private Sub SetupLighting()

Dim lghtDirectional As D3DLIGHT8
Dim lghtSpot As D3DLIGHT8
Dim lghtPoint1 As D3DLIGHT8
Dim lghtPoint2 As D3DLIGHT8

Dim vecLight As D3DVECTOR

    With lghtDirectional
    
        .Type = D3DLIGHT_DIRECTIONAL
        .Direction = MakeVector(-0.4, -0.8, 0.2)
        .Position = MakeVector(1, 1, 1) ' shouldn't be left as 0
        .Range = 100 ' shouldn't be left as 0
        .diffuse = CreateD3DColorVal(1, 1, 1, 0.9) ' light yellow (sun) light
        .Ambient = .diffuse

    End With
    
    With lghtSpot
        
        .Type = D3DLIGHT_SPOT
        .Range = 30#
        .diffuse = CreateD3DColorVal(1, 0.95, 0.95, 1)
'        .Direction = MakeVector(Sin(clPlayer.sgAngleY / Const_sgRad2Deg), 0, -Cos(clPlayer.sgAngleY / Const_sgRad2Deg))
'        .Position = MakeVector(clPlayer.sgPosX, clPlayer.sgPosY + 1.5, clPlayer.sgPosZ)
        .Theta = 0.1 * Const_sgPi
        .Phi = 0.4 * Const_sgPi
        .Attenuation0 = 0.05
        .Attenuation1 = 0.05
        .Attenuation2 = 0
        
    End With

    With lghtPoint1
    
        .Type = D3DLIGHT_POINT
        .diffuse = CreateD3DColorVal(1, 1, 1, 0.95)
        .Position = MakeVector(-300, 100, -300)
        .Range = 500#
        .Attenuation0 = 0.01
        .Attenuation1 = 0.01 '1#
        .Attenuation2 = 0#
    
    End With
    
    With lghtPoint2
    
        .Type = D3DLIGHT_POINT
        .diffuse = CreateD3DColorVal(1, 1, 1, 0.95)
        .Position = MakeVector(300, 100, 300)
        .Range = 500#
        .Attenuation0 = 0.01
        .Attenuation1 = 0.01 '1#
        .Attenuation2 = 0#
    
    End With
    
    clD3DDevice.SetLight 0, lghtDirectional
'    clD3DDevice.SetLight 1, lghtSpot
'    clD3DDevice.SetLight 2, lghtPoint1
'    clD3DDevice.SetLight 3, lghtPoint2
    
    clD3DDevice.LightEnable 0, 1
'    clD3DDevice.LightEnable 1, 0
'    clD3DDevice.LightEnable 2, 0
'    clD3DDevice.LightEnable 3, 0
    
'    clD3DDevice.SetRenderState D3DRS_AMBIENT, RGB(160, 160, 160)
    clD3DDevice.SetRenderState D3DRS_AMBIENT, clScene.lAmbientLightColour

End Sub

Private Sub Form_Resize()

    Me.Caption = Const_strApplicationShortName + " - (" & Me.ScaleWidth & " x " & Me.ScaleHeight & ")"

    'tpUsedDispMode.Width = Me.ScaleWidth
    'tpUsedDispMode.Height = Me.ScaleHeight

End Sub

Sub SetupPixelFog(lColor As Long, fcMode As CONST_D3DFOGMODE)
    
Dim sgStartFog As Single
Dim sgEndFog As Single
Dim sgDensity As Single
    
    ' For linear mode
    sgStartFog = 1: sgEndFog = 2
    
    ' For exponential mode
    sgDensity = 0.8
'    sgDensity = 0.1
 
    ' Enable fog blending.
    clD3DDevice.SetRenderState D3DRS_FOGENABLE, 1
 
    ' Set the fog color.
    clD3DDevice.SetRenderState D3DRS_FOGCOLOR, lColor
    
    ' Set fog parameters.
    If fcMode = D3DFOG_LINEAR Then
    
        clD3DDevice.SetRenderState D3DRS_FOGVERTEXMODE, fcMode
        clD3DDevice.SetRenderState D3DRS_FOGTABLEMODE, fcMode
        clD3DDevice.SetRenderState D3DRS_FOGSTART, sgStartFog
        clD3DDevice.SetRenderState D3DRS_FOGEND, sgEndFog
        
    Else
    
        clD3DDevice.SetRenderState D3DRS_FOGVERTEXMODE, fcMode
        clD3DDevice.SetRenderState D3DRS_FOGTABLEMODE, fcMode
        clD3DDevice.SetRenderState D3DRS_FOGDENSITY, sgDensity

    End If

    clD3DDevice.SetRenderState D3DRS_RANGEFOGENABLE, 1

End Sub

Private Sub RenderGeoObject(clGeoObject As Class_GeoObject)

Dim clCurrentVertexBuffer As Direct3DVertexBuffer8
'Dim tpVertexBufferDescription As D3DVERTEXBUFFER_DESC

    With clD3DDevice

        On Local Error Resume Next
    
        .SetTexture 0, gCol_Geo_TexDiffuseTextures("t" & clGeoObject.lMaterialIndex)
    
        If Err.Number = 0 Then GoTo lblContinue
    
lblSetNoTex:
    
        .SetTexture 0, Nothing
    
lblContinue:
    
        On Error GoTo 0
        
        .SetMaterial lptpMatSceneMaterials(clGeoObject.lMaterialIndex)
    
        Set clCurrentVertexBuffer = clGeoObject.D3DVertexBuffer
    
        .SetStreamSource 0, clCurrentVertexBuffer, Len(tpDummyVertex)
        .DrawPrimitive D3DPT_TRIANGLELIST, 0, clGeoObject.lVertexCount / 3

    End With

End Sub

Public Function MainLoop()

    Do While bRunning
        
        clGame.MovePlayers
        RenderSounds
        
        If clGame.Col_clPlayers.Count > 1 Then Form_NetworkListen.SendPlayerData
        
        Render
        
        lFramesCount = lFramesCount + 1
        
        DoEvents
    
    Loop
    
End Function
1	cvsrabit	1.1	VERSION 5.00
2			Begin VB.Form Form_D3D
3			BorderStyle = 5 'Sizable ToolWindow
4			Caption = "RRR"
5			ClientHeight = 7200
6			ClientLeft = 60
7			ClientTop = 345
8			ClientWidth = 9600
9			ClipControls = 0 'False
10			FillStyle = 0 'Solid
11			BeginProperty Font
12			Name = "Terminal"
13			Size = 6
14			Charset = 255
15			Weight = 700
16			Underline = 0 'False
17			Italic = 0 'False
18			Strikethrough = 0 'False
19			EndProperty
20			KeyPreview = -1 'True
21			MinButton = 0 'False
22			ScaleHeight = 480
23			ScaleMode = 3 'Pixel
24			ScaleWidth = 640
25			ShowInTaskbar = 0 'False
26			StartUpPosition = 3 'Windows Default
27			Begin VB.PictureBox Picture_TrackMap
28			Appearance = 0 'Flat
29			AutoSize = -1 'True
30			BackColor = &H80000005&
31			BorderStyle = 0 'None
32			ClipControls = 0 'False
33			FillStyle = 0 'Solid
34			ForeColor = &H80000008&
35			Height = 6000
36			Left = 0
37			ScaleHeight = 400
38			ScaleMode = 3 'Pixel
39			ScaleWidth = 400
40			TabIndex = 0
41			Top = 0
42			Visible = 0 'False
43			Width = 6000
44			End
45			End
46			Attribute VB_Name = "Form_D3D"
47			Attribute VB_GlobalNameSpace = False
48			Attribute VB_Creatable = False
49			Attribute VB_PredeclaredId = True
50			Attribute VB_Exposed = False
51			Option Explicit
52			'
53
54			Public Function Initialise() As Boolean
55
56			Dim lAdapter As Long
57			Dim lD3DCreateFlags As CONST_D3DCREATEFLAGS
58
59			Dim fcDevCaps As D3DCAPS8
60
61			Dim matProjection As D3DMATRIX
62
63			lAdapter = D3DADAPTER_DEFAULT
64
65			On Error GoTo ErrHandler
66
67			ConPrint Const_strConsoleBlockTitlePre + "testing device features:" + Const_strConsoleBlockTitlePost
68			ConPrint " " & clSystem.D3D8.GetAdapterCount & " display adapter(s) found.[brk][brk]"
69
70			With tpD3DPresentParameters
71
72			If Form_Start.Check_Windowed.Value = 1 Then
73
74			clSystem.D3D8.GetAdapterDisplayMode lAdapter, tpUsedDispMode
75
76			.BackBufferCount = 1
77			.BackBufferFormat = tpUsedDispMode.Format
78
79			.Windowed = 1
80
81			Else
82
83			clSystem.D3D8.EnumAdapterModes 0, Form_Start.Combo_RefreshRate.ItemData(Form_Start.Combo_RefreshRate.ListIndex), tpUsedDispMode
84
85			.BackBufferCount = 1
86			.BackBufferFormat = tpUsedDispMode.Format
87			.BackBufferWidth = tpUsedDispMode.Width
88			.BackBufferHeight = tpUsedDispMode.Height
89			.FullScreen_RefreshRateInHz = tpUsedDispMode.RefreshRate
90			' .FullScreen_PresentationInterval = 0
91
92			End If
93
94			.hDeviceWindow = Form_D3D.hWnd
95
96			.AutoDepthStencilFormat = D3DFMT_D16
97			.EnableAutoDepthStencil = 1
98
99			' .SwapEffect = D3DSWAPEFFECT_FLIP
100
101			If Form_Start.Check_Antialias.Value = 1 Then
102
103			.SwapEffect = D3DSWAPEFFECT_DISCARD
104
105			If Form_Start.Option_MultisampleType2.Value = True Then
106
107			If clSystem.D3D8.CheckDeviceMultiSampleType(lAdapter, D3DDEVTYPE_HAL, D3DFMT_R8G8B8, .Windowed, D3DMULTISAMPLE_2_SAMPLES) Then .MultiSampleType = D3DMULTISAMPLE_2_SAMPLES
108
109			ElseIf Form_Start.Option_MultisampleType4.Value = True Then
110
111			If clSystem.D3D8.CheckDeviceMultiSampleType(lAdapter, D3DDEVTYPE_HAL, D3DFMT_R8G8B8, .Windowed, D3DMULTISAMPLE_4_SAMPLES) Then .MultiSampleType = D3DMULTISAMPLE_4_SAMPLES
112
113			End If
114
115			Else
116
117			.SwapEffect = D3DSWAPEFFECT_COPY '_VSYNC
118
119			End If
120
121			If .MultiSampleType > D3DMULTISAMPLE_NONE Then
122
123			ConPrint " antialiasing type is [c02]" & .MultiSampleType & "x multisampling[c07].[brk]"
124
125			Else
126
127			ConPrint " antialiasing is [c12]deactivated[c07].[brk]"
128
129			End If
130
131			End With
132
133			'############################
134			'## CHECK THE DEVICE CAPABILITIES ##
135			'###########################
136
137			On Local Error Resume Next
138
139			clSystem.D3D8.GetDeviceCaps lAdapter, D3DDEVTYPE_HAL, fcDevCaps
140
141			If Err.Number = D3DERR_INVALIDDEVICE Then
142
143			'We couldn't get data from the hardware device - probably doesn't exist...
144			clSystem.D3D8.GetDeviceCaps lAdapter, D3DDEVTYPE_REF, fcDevCaps
145			Err.Clear ' Remove the error value..
146
147			End If
148
149			ConPrint " hardware transform and lighting... "
150
151			'...for Hardware vertex processing:
152			If (fcDevCaps.DevCaps And D3DDEVCAPS_HWTRANSFORMANDLIGHT) Then
153
154			lD3DCreateFlags = D3DCREATE_HARDWARE_VERTEXPROCESSING
155			ConPrint Const_strConsoleTextOK
156
157			Else
158
159			lD3DCreateFlags = D3DCREATE_SOFTWARE_VERTEXPROCESSING
160			ConPrint Const_strConsoleTextFail
161
162			End If
163
164			ConPrint " pure device support... "
165
166			'...for Pure Device processing:
167			If (fcDevCaps.DevCaps And D3DDEVCAPS_PUREDEVICE) Then
168
169			lD3DCreateFlags = lD3DCreateFlags Or D3DCREATE_PUREDEVICE
170			ConPrint Const_strConsoleTextOK
171
172			Else
173
174			ConPrint Const_strConsoleTextFail
175
176			End If
177
178			Dim fcPRasterCapsFlags As CONST_D3DPRASTERCAPSFLAGS
179
180			fcPRasterCapsFlags = fcDevCaps.RasterCaps
181
182			ConPrint " colour dithering... "
183
184			If (fcPRasterCapsFlags And D3DPRASTERCAPS_DITHER) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail
185
186			fcPRasterCapsFlags = fcDevCaps.RasterCaps
187
188			ConPrint " anisotropic filtering... "
189
190			If (fcPRasterCapsFlags And D3DPRASTERCAPS_ANISOTROPY) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail
191
192			ConPrint " edge antialiasing... "
193
194			If (fcPRasterCapsFlags And D3DPRASTERCAPS_ANTIALIASEDGES) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail
195
196			ConPrint " range-based fog... "
197
198			If (fcPRasterCapsFlags And D3DPRASTERCAPS_FOGRANGE) Then ConPrint Const_strConsoleTextOK Else ConPrint Const_strConsoleTextFail
199
200			' This line creates a device that uses a hardware device if possible; software vertex processing and uses the form as it's target
201			Set clD3DDevice = clSystem.D3D8.CreateDevice(lAdapter, D3DDEVTYPE_HAL, Form_D3D.hWnd, lD3DCreateFlags, tpD3DPresentParameters)
202
203			' Configure the rendering device
204			clD3DDevice.SetVertexShader Const_lFVF_Vertex '//Tell it what type of vertex we are using
205			clD3DDevice.SetRenderState D3DRS_LIGHTING, 1 '//Enable lighting.
206			clD3DDevice.SetRenderState D3DRS_ZENABLE, 1
207			clD3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
208
209			If tpD3DPresentParameters.MultiSampleType > 0 Then clD3DDevice.SetRenderState D3DRS_MULTISAMPLE_ANTIALIAS, 1
210
211			' clD3DDevice.SetRenderState D3DRS_ALPHABLENDENABLE, 1
212			' clD3DDevice.SetRenderState D3DRS_RANGEFOGENABLE, 1
213
214			' clD3DDevice.SetRenderState D3DRS_DITHERENABLE, True
215			' clD3DDevice.SetRenderState D3DRS_EDGEANTIALIAS, True
216			' clD3DDevice.SetRenderState D3DRS_SPECULARENABLE, True
217			' clD3DDevice.SetRenderState D3DRS_FOGENABLE, True
218
219			'//configure the world matrices
220
221			'//1. The World Matrix
222			' D3DXMatrixIdentity matWorld
223			clD3DDevice.SetTransform D3DTS_WORLD, tpMatIdentity 'commit this matrix to the device
224
225			'//3. The projection Matrix
226			D3DXMatrixPerspectiveFovLH matProjection, 0.3 * Const_sgPi, tpUsedDispMode.Height / tpUsedDispMode.Width, 0.1, 300
227			clD3DDevice.SetTransform D3DTS_PROJECTION, matProjection
228
229			Initialise = True '//We succeeded
230
231			ConPrint "[brk]"
232
233			Exit Function
234
235			ErrHandler:
236
237			Initialise = False
238			ConPrint "[brk][c03]error returned:[brk]no. " & Err.Number & ": " + Err.Description + "[c15][brk]"
239
240			End Function
241
242			Public Sub Render()
243
244			Dim clCurrentObject As Class_GeoObject
245			Dim clPlayer As Class_Player
246
247			Dim bIsPlayerObject As Boolean
248
249			Dim tpMatTemp1 As D3DMATRIX
250			Dim tpMatTemp2 As D3DMATRIX
251
252			Dim l As Long
253			Dim lPlayerIndex As Long
254			Dim lVertexCount As Long
255
256			Dim tpVecPlayerPosition As D3DVECTOR
257
258			With clD3DDevice
259
260			If Not lplKeyControlFlags(vbKeyQ) Then .Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, clScene.lBackgroundColour, 1#, 0
261			' .Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, clScene.lBackgroundColour, 1#, 0
262
263			' SetupLighting
264
265			.BeginScene
266
267			' SetupPixelFog D3DColorXRGB(1#, 1#, 1#), D3DFOG_LINEAR
268
269			For l = 1 To clScene.Col_clGeoObjects.Count
270
271			Set clCurrentObject = clScene.Col_clGeoObjects(l)
272
273			bIsPlayerObject = LCase(Left(clCurrentObject.strName, 3)) = "pla"
274
275			If bIsPlayerObject Then
276
277			For lPlayerIndex = 1 To clGame.Col_clPlayers.Count
278
279			Set clPlayer = clGame.Col_clPlayers(lPlayerIndex)
280
281			If bShowPlayer Or clPlayer.lPlayerType <> ePT_LocalHuman Then
282
283			tpMatTemp1 = tpMatIdentity
284
285			tpVecPlayerPosition = clPlayer.GetPosition
286
287			D3DXMatrixTranslation tpMatTemp1, clCurrentObject.sgPositionX, -clCurrentObject.sgPositionZ, clCurrentObject.sgPositionY
288
289			tpMatTemp2 = tpMatIdentity
290			D3DXMatrixRotationY tpMatTemp2, -clPlayer.sgAngleY * Const_sgDeg2Rad
291			D3DXMatrixMultiply tpMatTemp1, tpMatTemp1, tpMatTemp2
292
293			tpMatTemp2 = tpMatIdentity
294			D3DXMatrixTranslation tpMatTemp2, tpVecPlayerPosition.X, tpVecPlayerPosition.Y, tpVecPlayerPosition.Z
295			D3DXMatrixMultiply tpMatTemp1, tpMatTemp1, tpMatTemp2
296
297			.SetTransform D3DTS_WORLD, tpMatTemp1
298			RenderGeoObject clCurrentObject
299
300			End If
301
302			Next lPlayerIndex
303
304			Else
305
306			.SetTransform D3DTS_WORLD, tpMatIdentity
307			RenderGeoObject clCurrentObject
308
309			End If
310
311			Next l
312
313			DrawOverlay
314
315			.EndScene
316
317			.Present ByVal 0, ByVal 0, 0, ByVal 0
318
319			End With
320
321			End Sub
322
323			Private Function CheckDisplayMode(Width As Long, Height As Long, Depth As Long) As CONST_D3DFORMAT
324
325			Dim i As Long
326			Dim tpUsedDispMode As D3DDISPLAYMODE
327
328			For i = 0 To clSystem.D3D8.GetAdapterModeCount(0) - 1
329
330			clSystem.D3D8.EnumAdapterModes 0, i, tpUsedDispMode
331
332			If tpUsedDispMode.Width = Width Then
333
334			If tpUsedDispMode.Height = Height Then
335
336			If tpUsedDispMode.Format = D3DFMT_R5G6B5 Or D3DFMT_X1R5G5B5 Or D3DFMT_X4R4G4B4 Then
337
338			'16 bit mode
339			If Depth = 16 Then
340
341			CheckDisplayMode = tpUsedDispMode.Format
342			Exit Function
343
344			End If
345
346			ElseIf tpUsedDispMode.Format = D3DFMT_R8G8B8 Or D3DFMT_X8R8G8B8 Then
347
348			'32bit mode
349			If Depth = 32 Then
350
351			CheckDisplayMode = tpUsedDispMode.Format
352			Exit Function
353
354			End If
355
356			End If
357
358			End If
359
360			End If
361
362			Next i
363
364			CheckDisplayMode = D3DFMT_UNKNOWN
365
366			End Function
367
368			Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
369
370			If KeyCode = vbKeyEscape Then
371
372			If lMenuIndex = 0 Then
373
374			lMenuIndex = 1
375			lMenuSelectedItem = 0
376
377			Else
378
379			lMenuIndex = 0
380
381			End If
382
383			ElseIf lMenuIndex = 0 Then
384
385			' If KeyCode = vbKeyE Then
386			'
387			' clD3DDevice.SetRenderState D3DRS_LIGHTING, 1 'Enable lighting.
388			'
389			' ElseIf KeyCode = vbKeyD Then
390			'
391			' clD3DDevice.SetRenderState D3DRS_LIGHTING, 0 'Disable lighting.
392			'
393			' ElseIf KeyCode = vbKeyW Then
394			'
395			' clD3DDevice.SetRenderState D3DRS_FILLMODE, D3DFILL_WIREFRAME 'Set wireframe rendering.
396			'
397			' ElseIf KeyCode = vbKeyS Then
398			'
399			' clD3DDevice.SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID 'Set solid rendering.
400			'
401			' Else
402
403			If KeyCode = vbKeyC Then
404
405			lCamMode = lCamMode + 1
406
407			If lCamMode = 6 Then lCamMode = 0
408
409			Else
410
411			If lLocalPlayerHandle <> 0 Then
412
413			clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags = clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags Or lplKeyControlFlags(KeyCode)
414			' Debug.Print clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags
415
416			End If
417
418			End If
419
420			Else
421
422			If KeyCode = vbKeyReturn Then
423
424			Dim lpstrArguments() As String
425
426			lpstrArguments = Split(Col_clMenus(lMenuIndex).Item(lMenuSelectedItem + 1).strCommand, " ")
427
428			If UBound(lpstrArguments) >= 0 Then
429
430			Select Case lpstrArguments(0)
431
432			Case "exit"
433
434			clGame.RemoveAllPlayers
435			DeleteScene
436
437			Case "menu"
438
439			lMenuIndex = Val(lpstrArguments(1))
440			lMenuSelectedItem = 0
441
442			Case "quit"
443
444			bRunning = False
445			clGame.RemoveAllPlayers
446			DeleteScene
447
448			Case "single"
449
450			lMenuIndex = 0
451			DoEvents
452			StartSinglePlayerGame
453
454			End Select
455
456			End If
457
458			ElseIf KeyCode = vbKeyDown Then
459
460			lMenuSelectedItem = lMenuSelectedItem + 1
461
462			If lMenuSelectedItem >= Col_clMenus(lMenuIndex).Count Then lMenuSelectedItem = 0
463
464			ElseIf KeyCode = vbKeyUp Then
465
466			lMenuSelectedItem = lMenuSelectedItem - 1
467
468			If lMenuSelectedItem < 0 Then lMenuSelectedItem = Col_clMenus(lMenuIndex).Count - 1
469
470			End If
471
472			End If
473
474			End Sub
475
476			Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
477
478			' lplKeyControlFlags(KeyCode) = False
479
480			If lLocalPlayerHandle <> 0 Then clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags = clGame.Col_clPlayers("p" & lLocalPlayerHandle).lPlayerControlFlags And Not lplKeyControlFlags(KeyCode)
481
482			End Sub
483
484			Private Sub Form_Load()
485
486			Me.Show
487
488			bRunning = Initialise()
489
490			If bRunning Then
491
492			SetupOverlay
493
494			SetupKeyCommands
495			SetupLighting
496
497			If Form_Start.Check_Windowed.Value = 1 Then
498
499			tpUsedDispMode.Width = Me.ScaleWidth
500			tpUsedDispMode.Height = Me.ScaleHeight
501
502			End If
503
504			ConPrint Const_strConsoleTextLine + _
505			Const_strConsoleTextLineIndent + "[c14]key commands:[c15][brk]" + _
506			Const_strConsoleTextLine + _
507			Const_strConsoleTextLineIndent + " up ... accelerate forward[brk]" + _
508			Const_strConsoleTextLineIndent + " down ... accelerate backward[brk]" + _
509			Const_strConsoleTextLineIndent + "left/right ... rotate steering wheel[brk]" + _
510			Const_strConsoleTextLineIndent + " space ... break[brk]" + _
511			Const_strConsoleTextLineIndent + " shift ... use horn[brk]" + _
512			Const_strConsoleTextLineIndent + " c ... change camera mode[brk]" + _
513			Const_strConsoleTextLineIndent + " esc ... show/hide menu[brk]" + _
514			Const_strConsoleTextLine
515
516			' Const_strConsoleTextLineIndent + " w/s ... wireframe/solid render mode[brk]" + _
517			' Const_strConsoleTextLineIndent + " e/d ... enable/disable lighted shading[brk]" + _
518
519			clSystem.DS8SetCooperativeLevel Form_D3D.hWnd
520
521			End If
522
523			MainLoop
524
525			On Error Resume Next
526
527			Set clD3DDevice = Nothing
528			' Set D3D = Nothing
529			' Set DX = Nothing
530
531			' clDSSoundBuffer1.Stop
532			' clDSSoundBuffer2.Stop
533			' clDSSoundBuffer3.Stop
534
535			Form_Start.Command_Start.Enabled = True
536			Unload Me
537
538			End
539
540			End Sub
541
542			Private Sub SetupLighting()
543
544			Dim lghtDirectional As D3DLIGHT8
545			Dim lghtSpot As D3DLIGHT8
546			Dim lghtPoint1 As D3DLIGHT8
547			Dim lghtPoint2 As D3DLIGHT8
548
549			Dim vecLight As D3DVECTOR
550
551			With lghtDirectional
552
553			.Type = D3DLIGHT_DIRECTIONAL
554			.Direction = MakeVector(-0.4, -0.8, 0.2)
555			.Position = MakeVector(1, 1, 1) ' shouldn't be left as 0
556			.Range = 100 ' shouldn't be left as 0
557			.diffuse = CreateD3DColorVal(1, 1, 1, 0.9) ' light yellow (sun) light
558			.Ambient = .diffuse
559
560			End With
561
562			With lghtSpot
563
564			.Type = D3DLIGHT_SPOT
565			.Range = 30#
566			.diffuse = CreateD3DColorVal(1, 0.95, 0.95, 1)
567			' .Direction = MakeVector(Sin(clPlayer.sgAngleY / Const_sgRad2Deg), 0, -Cos(clPlayer.sgAngleY / Const_sgRad2Deg))
568			' .Position = MakeVector(clPlayer.sgPosX, clPlayer.sgPosY + 1.5, clPlayer.sgPosZ)
569			.Theta = 0.1 * Const_sgPi
570			.Phi = 0.4 * Const_sgPi
571			.Attenuation0 = 0.05
572			.Attenuation1 = 0.05
573			.Attenuation2 = 0
574
575			End With
576
577			With lghtPoint1
578
579			.Type = D3DLIGHT_POINT
580			.diffuse = CreateD3DColorVal(1, 1, 1, 0.95)
581			.Position = MakeVector(-300, 100, -300)
582			.Range = 500#
583			.Attenuation0 = 0.01
584			.Attenuation1 = 0.01 '1#
585			.Attenuation2 = 0#
586
587			End With
588
589			With lghtPoint2
590
591			.Type = D3DLIGHT_POINT
592			.diffuse = CreateD3DColorVal(1, 1, 1, 0.95)
593			.Position = MakeVector(300, 100, 300)
594			.Range = 500#
595			.Attenuation0 = 0.01
596			.Attenuation1 = 0.01 '1#
597			.Attenuation2 = 0#
598
599			End With
600
601			clD3DDevice.SetLight 0, lghtDirectional
602			' clD3DDevice.SetLight 1, lghtSpot
603			' clD3DDevice.SetLight 2, lghtPoint1
604			' clD3DDevice.SetLight 3, lghtPoint2
605
606			clD3DDevice.LightEnable 0, 1
607			' clD3DDevice.LightEnable 1, 0
608			' clD3DDevice.LightEnable 2, 0
609			' clD3DDevice.LightEnable 3, 0
610
611			' clD3DDevice.SetRenderState D3DRS_AMBIENT, RGB(160, 160, 160)
612			clD3DDevice.SetRenderState D3DRS_AMBIENT, clScene.lAmbientLightColour
613
614			End Sub
615
616			Private Sub Form_Resize()
617
618			Me.Caption = Const_strApplicationShortName + " - (" & Me.ScaleWidth & " x " & Me.ScaleHeight & ")"
619
620			'tpUsedDispMode.Width = Me.ScaleWidth
621			'tpUsedDispMode.Height = Me.ScaleHeight
622
623			End Sub
624
625			Sub SetupPixelFog(lColor As Long, fcMode As CONST_D3DFOGMODE)
626
627			Dim sgStartFog As Single
628			Dim sgEndFog As Single
629			Dim sgDensity As Single
630
631			' For linear mode
632			sgStartFog = 1: sgEndFog = 2
633
634			' For exponential mode
635			sgDensity = 0.8
636			' sgDensity = 0.1
637
638			' Enable fog blending.
639			clD3DDevice.SetRenderState D3DRS_FOGENABLE, 1
640
641			' Set the fog color.
642			clD3DDevice.SetRenderState D3DRS_FOGCOLOR, lColor
643
644			' Set fog parameters.
645			If fcMode = D3DFOG_LINEAR Then
646
647			clD3DDevice.SetRenderState D3DRS_FOGVERTEXMODE, fcMode
648			clD3DDevice.SetRenderState D3DRS_FOGTABLEMODE, fcMode
649			clD3DDevice.SetRenderState D3DRS_FOGSTART, sgStartFog
650			clD3DDevice.SetRenderState D3DRS_FOGEND, sgEndFog
651
652			Else
653
654			clD3DDevice.SetRenderState D3DRS_FOGVERTEXMODE, fcMode
655			clD3DDevice.SetRenderState D3DRS_FOGTABLEMODE, fcMode
656			clD3DDevice.SetRenderState D3DRS_FOGDENSITY, sgDensity
657
658			End If
659
660			clD3DDevice.SetRenderState D3DRS_RANGEFOGENABLE, 1
661
662			End Sub
663
664			Private Sub RenderGeoObject(clGeoObject As Class_GeoObject)
665
666			Dim clCurrentVertexBuffer As Direct3DVertexBuffer8
667			'Dim tpVertexBufferDescription As D3DVERTEXBUFFER_DESC
668
669			With clD3DDevice
670
671			On Local Error Resume Next
672
673			.SetTexture 0, gCol_Geo_TexDiffuseTextures("t" & clGeoObject.lMaterialIndex)
674
675			If Err.Number = 0 Then GoTo lblContinue
676
677			lblSetNoTex:
678
679			.SetTexture 0, Nothing
680
681			lblContinue:
682
683			On Error GoTo 0
684
685			.SetMaterial lptpMatSceneMaterials(clGeoObject.lMaterialIndex)
686
687			Set clCurrentVertexBuffer = clGeoObject.D3DVertexBuffer
688
689			.SetStreamSource 0, clCurrentVertexBuffer, Len(tpDummyVertex)
690			.DrawPrimitive D3DPT_TRIANGLELIST, 0, clGeoObject.lVertexCount / 3
691
692			End With
693
694			End Sub
695
696			Public Function MainLoop()
697
698			Do While bRunning
699
700			clGame.MovePlayers
701			RenderSounds
702
703			If clGame.Col_clPlayers.Count > 1 Then Form_NetworkListen.SendPlayerData
704
705			Render
706
707			lFramesCount = lFramesCount + 1
708
709			DoEvents
710
711			Loop
712
713			End Function
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26