mmain.bas

一个d3d实例程序

        ' Resume to ignore the weird math errors Direct3DRM reports from time to time
        Resume Next

End Sub

Public Sub AppTerminate()

    ' Enable error handling...
        On Error GoTo E_AppTerminate

    ' Setup local variables ...
        Dim L_nRun As Integer             ' Variable to run through various array data
    
    ' Return control from DirectX to windows ...

        ' Restore old resolution and depth
        G_oDDInstance.RestoreDisplayMode
    
        ' Return control to windows
        G_oDDInstance.SetCooperativeLevel fMain.hWnd, DDSCL_NORMAL
        
    ' Reset DirectX objects ...
        
        ' D3DRM Flame animation ...
            
            Set G_oD3DLightFlame1 = Nothing
            Set G_oD3DTextureFlame1 = Nothing
            Set G_oDDSurfaceFlame1 = Nothing
            Set G_oD3DFrameFlame1 = Nothing
            
            Set G_oD3DLightFlame2 = Nothing
            Set G_oD3DTextureFlame2 = Nothing
            Set G_oDDSurfaceFlame2 = Nothing
            Set G_oD3DFrameFlame2 = Nothing
            
            Set G_oDDResourceFlame = Nothing
        
        ' D3DRM Lava animation ...
        
            Set G_oD3DTextureLava = Nothing
            Set G_oDDSurfaceLava = Nothing
            Set G_oDDResourceLava = Nothing
            Set G_oD3DMaterialLava = Nothing
            Set G_oD3DMaterialGround = Nothing
        
        ' D3DRM Mirror animation ...
        
            Set G_oD3DTextureMirror = Nothing
            Set G_oD3DFrameMirror = Nothing
                
        ' D3DRM Rotor animation ...
        
            Set G_oD3DRotorFrame = Nothing
            Set G_oD3DTextureRotor = Nothing
            Set G_oD3DMaterialRotor = Nothing
        
        ' D3DRM display system ...
        
            Set G_oD3DCameraFrame = Nothing
            Set G_oD3DMasterFrame = Nothing
            Set G_oD3DViewport = Nothing
            Set G_oD3DDevice = Nothing
            
            Set G_oD3DViewportMirror = Nothing
            Set G_oD3DDeviceMirror = Nothing
            Set G_oDDSurfaceMirror = Nothing
            Set G_oD3DMaterialMirror = Nothing
        
        ' DD Display system ...
        
            Set G_oDDBackbuffer = Nothing
            Set G_oDDPrimary = Nothing
        
        ' DD Character animation ...
        
            Set G_oDDSurfaceChars = Nothing
                
        ' DD Windows ...
        
            For L_nRun = 0 To 4
                Set G_dDDWindow(L_nRun).oDDSurface = Nothing
            Next
                
        ' DD status text for D3DRM window...
        
            Set G_oDDSurfaceStatus = Nothing
        
        ' DD Explosions ...
            
            Set G_oDDSurfaceExplo = Nothing
                
        ' DirectSound ...
        
            G_oDSBufferMusic.Stop
            Set G_oDSBufferMusic = Nothing
            
            For L_nRun = 0 To 7
                If Not G_dExplo(L_nRun).oDSBuffer Is Nothing Then
                    G_dExplo(L_nRun).oDSBuffer.Stop
                    Set G_dExplo(L_nRun).oDSBuffer = Nothing
                End If
            Next
        
        ' DirectX interfaces ...
        
            Set G_oDSInstance = Nothing
            Set G_oDDInstance = Nothing
            Set G_oD3DInstance = Nothing
        
    ' Error handling ...
        
        Exit Sub

E_AppTerminate:

        ' Resume to ensure that all objects available are cleaned up
        Resume Next

End Sub




Private Sub CreateScene()

    ' Enable error handling...
        On Error GoTo E_CreateScene

    ' Setup local variables ...
        Dim L_oD3DLight As IDirect3DRMLight     ' Variable for light creating
        Dim L_nRun As Single                    ' Variable to run through arrays
        Dim L_dDDCK As DDCOLORKEY               ' Color key for making status display transparent
        
    ' Initialize scenario settings ...
    
        ' Create position lookup table for camera
        For L_nRun = 0 To 179
            With G_dCamPosLookup(L_nRun)
                .z = 5
                .X = 11 + Sin((L_nRun * 2) * PIFACTOR) * 7.8
                .Y = 10.5 + Cos((L_nRun * 2) * PIFACTOR) * 7.8
            End With
        Next
        
        ' Set the projection model and properties for the viewport
        With G_oD3DViewport
            .SetProjection D3DRMPROJECT_PERSPECTIVE
            .SetBack 20
            .SetFront 1
            .SetUniformScaling 1
        End With
        
        ' Set the scene properties (fog, backcolor)
        With G_oD3DMasterFrame
            .SetSceneBackgroundRGB 0, 0, 0
            .SetSceneFogColor D3DRMCreateColorRGB(0.2, 0.2, 0.3)
            .SetSceneFogMode D3DRMFOG_EXPONENTIAL
            .SetSceneFogParams 1, 16, 0.1
            .SetSceneFogEnable 1
        End With
        
        ' Create ambient light
        G_oD3DInstance.CreateLightRGB D3DRMLIGHT_AMBIENT, 0.3, 0.3, 0.3, L_oD3DLight
        G_oD3DMasterFrame.AddLight L_oD3DLight
        Set L_oD3DLight = Nothing

        ' Load text for status display
        Set G_oDDSurfaceStatus = LoadBitmapIntoDXS(App.Path + "\text.bmp")
                
        ' Make text transparent
        L_dDDCK.dwColorSpaceHighValue = 0
        L_dDDCK.dwColorSpaceLowValue = 0
        G_oDDSurfaceStatus.SetColorKey DDCKEY_SRCBLT, L_dDDCK
        
    ' Error handling ...
    
        Exit Sub

E_CreateScene:

        AppError Err.Number, Err.Description, "CreateScene"
        Exit Sub

End Sub

Private Sub CreateRotor()

    ' Enable error handling...
        On Error GoTo E_CreateRotor

    ' Setup local variables ...
        
        Dim L_oD3DMeshbuilder As IDirect3DRMMeshBuilder2    ' Holds and loads the mesh for the rotor
        Dim L_oD3DWrap As IDirect3DRMWrap                   ' Wrap for calculating texture coordinates
        
    ' Create and load rotor mesh...
        
        ' Create meshbuilder to hold rotor
        G_oD3DInstance.CreateMeshBuilder L_oD3DMeshbuilder
        
        ' Load rotor from xfile
        L_oD3DMeshbuilder.Load App.Path + "\rotor.x", 0, 0, 0, 0
        
    ' Create and load rotor texture...
    
        ' Load rotor texture
        G_oD3DInstance.LoadTexture App.Path + "\rotor.bmp", G_oD3DTextureRotor
        
        ' Set texture to transparent
        G_oD3DTextureRotor.SetDecalTransparentColor 0
        G_oD3DTextureRotor.SetDecalTransparency 1
        
        ' Calculate texture coordinates for spherical wrapping
        G_oD3DInstance.CreateWrap D3DRMWRAP_SPHERE, Nothing, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 1, L_oD3DWrap
        L_oD3DWrap.Apply L_oD3DMeshbuilder
        Set L_oD3DWrap = Nothing
        
        ' Apply texture to mesh
        L_oD3DMeshbuilder.SetTexture G_oD3DTextureRotor
                        
        ' Create and apply material for rotor
        G_oD3DInstance.CreateMaterial 1, G_oD3DMaterialRotor
        G_oD3DMaterialRotor.SetSpecular 0.4, 0.4, 0.4
        L_oD3DMeshbuilder.SetMaterial G_oD3DMaterialRotor
        
    ' Prepare frame for rotor ...
    
        ' Create and locate frame to hold rotor
        G_oD3DInstance.CreateFrame G_oD3DMasterFrame, G_oD3DRotorFrame
        G_oD3DRotorFrame.SetPosition Nothing, 11, 11, 1.5
        G_oD3DRotorFrame.SetRotation Nothing, 0, 0, 1, -0.1
        
        ' Add rotor mesh to frame
        G_oD3DRotorFrame.AddVisual L_oD3DMeshbuilder
        
    ' Cleanup ...
    
        ' Clean up mesh
        Set L_oD3DMeshbuilder = Nothing
        
    ' Error handling ...
    
        Exit Sub

E_CreateRotor:

        AppError Err.Number, Err.Description, "CreateRotor"
        Exit Sub

End Sub

Private Sub CreateBack()

    ' Enable error handling...
        On Error GoTo E_CreateBack

    ' Setup local variables ...
        Dim L_nRun As Integer       ' Variable to run through array
        Dim L_dDDCK As DDCOLORKEY   ' Variable holding transparency key for explosion surface
        
    ' Create background stars ...
        
        For L_nRun = 0 To 1999
            With G_dStar(L_nRun)
                
                ' Set position
                .nX = Int(Rnd * 620) + 10
                .nY = Int(Rnd * 460) + 10
                                
                ' Set speed and color (the further "back", the slower and darker)
                Select Case Int(Rnd * 9) + 1
                
                    Case 1
                        .nSpeed = 3
                        .nColor = 65535
                    Case 2, 3, 4
                        .nSpeed = 2
                        .nColor = 14799 ' 31711
                    Case 5, 6, 7, 8, 9
                        .nSpeed = 1
                        .nColor = 6343 '14799
                        
                End Select
                
            End With
        Next
        
    ' Create background explosions ...
    
        ' Load surface holding explosion bitmaps
        Set G_oDDSurfaceExplo = LoadBitmapIntoDXS(App.Path + "\explo.bmp")
        
        ' Make surface transparent
        L_dDDCK.dwColorSpaceHighValue = 0
        L_dDDCK.dwColorSpaceLowValue = 0
        G_oDDSurfaceExplo.SetColorKey DDCKEY_SRCBLT, L_dDDCK
        
        ' Setup position, speed and sound for individual explosions
        For L_nRun = 0 To 14
            With G_dExplo(L_nRun)
            
                ' Initialize position and speed
                .nX = Int(Rnd * 600) + 5
                .nY = Int(Rnd * 460) + 10
                .nPhase = Int(Rnd * 15)
                
                ' Initialize sound for the first 8 explosions
                If L_nRun < 8 Then Set .oDSBuffer = LoadWaveIntoDSB(App.Path + "\explo.wav")
                
            End With
        Next
    
    ' Error handling ...
    
        Exit Sub

E_CreateBack:

        AppError Err.Number, Err.Description, "CreateBack"
        Exit Sub

End Sub

Private Sub CreateGround()

    ' Enable error handling
        On Error GoTo E_CreateGround

    ' Setup local variables ...
        Dim L_oD3DFace As IDirect3DRMFace                   ' Face to be added to meshbuilder
        Dim L_oD3DMeshbuilder As IDirect3DRMMeshBuilder2    ' Meshbuilder to hold created faces
        Dim L_nRunColumn As Single                                ' Variable to run through x face coordinates
        Dim L_nRunRow As Single                                ' Variable to run through y face coordinates
        
    ' Create ground ...
        
        ' Initialize meshbuilder
        G_oD3DInstance.CreateMeshBuilder L_oD3DMeshbuilder
        
        ' Load ground texture from file
        G_oD3DInstance.LoadTexture App.Path + "\ground.bmp", G_oD3DTextureGround
        
        ' Create Lava texture from surface, load Lava texture into surface
        Set G_oDDResourceLava = LoadBitmapIntoDXS(App.Path + "\lava.bmp")
        Set G_oDDSurfaceLava = MakeDXSurface(32, 32)
        G_oD3DInstance.CreateTextureFromSurface G_oDDSurfaceLava, G_oD3DTextureLava
        
        ' Create emissive material for lava
        G_oD3DInstance.CreateMaterial 1, G_oD3DMaterialLava
        G_oD3DMaterialLava.SetEmissive 0.5, 0.2, 0.1
        G_oD3DMaterialLava.SetSpecular 0.5, 0.5, 0.5
                
        ' Create specular material for ground
        G_oD3DInstance.CreateMaterial 1, G_oD3DMaterialGround
        G_oD3DMaterialGround.SetSpecular 0.5, 0.5, 0.5
        
        ' Create ground faces
        For L_nRunColumn = 8 To 13
            For L_nRunRow = 8 To 12
            
                ' Create face: Set vertices and texture coordinates
                G_oD3DInstance.CreateFace L_oD3DFace
                With L_oD3DFace
                    .AddVertex L_nRunColumn, L_nRunRow, 1
                    .AddVertex L_nRunColumn + 1, L_nRunRow, 1
                    .AddVertex L_nRunColumn + 1, L_nRunRow + 1, 1
                    .AddVertex L_nRunColumn, L_nRunRow + 1, 1
                    .SetTextureCoordinates 0, L_nRunColumn, L_nRunRow
                    .SetTextureCoordinates 1, L_nRunColumn + 1, L_nRunRow
                    .SetTextureCoordinates 2, L_nRunColumn + 1, L_nRunRow + 1
                    .SetTextureCoordinates 3, L_nRunColumn, L_nRunRow + 1
                End With
                
                ' Set face texture: Lava or Ground ,depending on position
                If (L_nRunRow < 10) Then
                    L_oD3DFace.SetTexture G_oD3DTextureLava
                    L_oD3DFace.SetMaterial G_oD3DMaterialLava
                Else
                    L_oD3DFace.SetTexture G_oD3DTextureGround
                    L_oD3DFace.SetMaterial G_oD3DMaterialGround
                End If
                
                ' Add face data to meshbuilder
                L_oD3DMeshbuilder.AddFace L_oD3DFace
            
                ' Reset face
                Set L_oD3DFace = Nothing
                
            Next
        Next
    
        ' Generate lighting normals and compact mesh
        L_oD3DMeshbuilder.GenerateNormals2 1, 3

        ' Add created mesh to frame
        G_oD3DMasterFrame.AddVisual L_oD3DMeshbuilder

        ' Clean up all DirectX objects
        Set L_oD3DMeshbuilder = Nothing