mmain.bas

一个d3d实例程序

Attribute VB_Name = "mMain"
Option Explicit

' Variables holding DDraw and D3DRM instances ...
Public G_oDDInstance As IDirectDraw                 ' Instance of DirectDraw interface
Public G_oD3DInstance As IDirect3DRM                ' Instance of Direct3DRM interface
Public G_oDSInstance As IDirectSound                ' Instance of DirectSound interface

' Variables for primary D3DRM display system ...
Public G_oD3DDevice As IDirect3DRMDevice2           ' Device to use for Direct3DRM operations
Public G_oD3DViewport As IDirect3DRMViewPort        ' Viewport for Direct3DRM to display results in
Public G_oD3DMasterFrame As IDirect3DRMFrame2       ' Top level frame that contains all other frames
Public G_oD3DCameraFrame As IDirect3DRMFrame2       ' Frame to contain the camera; The viewport is created from this frame
Public G_dD3DDriver As tD3DDriver                   ' Driver for use with Direct3DRM
Public G_bD3DDriverPresent As Boolean               ' Flag holding presence of driver (equals driver enumeration success)
Public G_dCamPosLookup(359) As D3DVECTOR            ' Lookup table of position values for camera
Public G_nCamPosCurrent As Integer                  ' Current position of camera according to lookup table
Public G_oDDSurfaceStatus As IDirectDrawSurface3    ' Surface holding text for status of d3drm

' Variables for sound system ...
Public G_oDSBufferMusic As IDirectSoundBuffer       ' Buffer holding constant background music

' Variables for DirectDraw blit system ...
Public G_oDDPrimary As IDirectDrawSurface3          ' Primary DirectDraw surface that is displayed on the form
Public G_oDDBackbuffer As IDirectDrawSurface3       ' Backbuffer DirectDraw surface that is flipped onto the primary
Public G_dDDWindow(2) As tDDWindow                  ' Buffers holding windows for effects

' Variables for rock and lava surface ...
Public G_oD3DTextureGround As IDirect3DRMTexture2  ' Texture for ground terrain
Public G_oD3DMaterialGround As IDirect3DRMMaterial ' Material for ground to add specularity
Public G_oD3DTextureLava As IDirect3DRMTexture2    ' Texture for animated Lava
Public G_oDDSurfaceLava As IDirectDrawSurface3     ' Surface holding current animated Lava
Public G_oDDResourceLava As IDirectDrawSurface3    ' Surface holding original Lava bitmap
Public G_oD3DMaterialLava As IDirect3DRMMaterial   ' Material for lava to make lava emissive

' Variables for rotor animation ...
Public G_oD3DRotorFrame As IDirect3DRMFrame2       ' Frame to hold rotor object
Public G_oD3DTextureRotor As IDirect3DRMTexture2   ' Texture for rotor object
Public G_oD3DMaterialRotor As IDirect3DRMMaterial  ' Material for rotor object

' Variables for flame decal ...
Public G_oDDResourceFlame As IDirectDrawSurface3   ' Surface containing images for flame animation
Public G_oD3DLightFlame1 As IDirect3DRMLight       ' Light for flame to illuminate surroundings
Public G_oD3DFrameFlame1 As IDirect3DRMFrame       ' Frame to contain light for flame
Public G_oDDSurfaceFlame1 As IDirectDrawSurface3   ' Surface containing current state of flame animation
Public G_oD3DTextureFlame1 As IDirect3DRMTexture2  ' Texture to contain decal
Public G_oD3DLightFlame2 As IDirect3DRMLight       ' Light for flame to illuminate surroundings
Public G_oD3DFrameFlame2 As IDirect3DRMFrame       ' Frame to contain light for flame
Public G_oDDSurfaceFlame2 As IDirectDrawSurface3   ' Surface containing current state of flame animation
Public G_oD3DTextureFlame2 As IDirect3DRMTexture2  ' Texture to contain decal

' Variables for mirror effect ...
Public G_oD3DTextureMirror As IDirect3DRMTexture2  ' Texture for mirror effect
Public G_oDDSurfaceMirror As IDirectDrawSurface3   ' Surface for mirror effect
Public G_oD3DViewportMirror As IDirect3DRMViewPort ' Viewport for mirror effect
Public G_oD3DDeviceMirror As IDirect3DRMDevice     ' Device for mirror effect
Public G_oD3DFrameMirror As IDirect3DRMFrame       ' Frame for mirror effect
Public G_oD3DMaterialMirror As IDirect3DRMMaterial ' Material for mirror effect

' Variables for flying text ...
Public G_bFontData(255, 34) As Boolean             ' Array holding character data
Public G_sDisplayText As String                    ' Text to display using scrolling characters
Public G_nCharScrollPos As Integer                 ' Current scroll offset of text
Public G_oDDSurfaceChars As IDirectDrawSurface3    ' Surface holding characters
 
' Variables for background animation ...
Public G_dStar(1999) As tStar                      ' Array holding data of moving stars
Public G_dExplo(14) As tExplo                      ' Array holding data on explosions
Public G_oDDSurfaceExplo As IDirectDrawSurface3    ' Surface holding explosion animations

' Various variables ...
Public G_nFrameCount As Long                       ' Global framecounter
Public G_nFrameAvg As Double                       ' Global average frames per second

' APPERROR: Reports application errors and terminates application properly
Public Sub AppError(nNumber As Long, sText As String, sSource As String)

    ' Enable error handling
    On Error Resume Next
    
    ' Cleanup
    Call AppTerminate
    
    ' Display error
    MsgBox "ERROR: " & IIf(InStr(1, UCase(sText), "AUTOM") > 0, "DirectX reports '" & GetDXError(nNumber) & "'", " Application reports '" & sText & "'") & vbCrLf & "SOURCE: " & sSource, vbCritical + vbOKOnly, "XDEMO3D"
    
    ' Terminate program
    End
    
End Sub

Public Sub AppInitialize()

    ' Enable error handling
        On Error GoTo E_AppInitialize

    ' Setup local variables...
    
        Dim L_dDDSD As DDSURFACEDESC           ' Utility surface description
        Dim L_dDDSC As DDSCAPS                 ' Utility display capabilities description
        Dim L_oD3DIM As IDirect3D2             ' Utility Direct3DIM interface for retrieving drivers
        Dim L_dDDCK As DDCOLORKEY              ' Color key for applying to various surfaces
        
    ' Initialize scrolling text ...
    
        G_sDisplayText = "             welcome to xdemo3d ... explore the world of directx ... explore the world of visual basic ... written by wolfgang kienreich in september 1998 ... contact me at [e-mail] ... thanx to patrice scribe for the great directx type library ... again vb rules ... feel free to spread this demo ... mail me if you've got some interesting vb stuff, or experience any problems with vb and directx ...          "
        
    ' Initialize DirectDraw interface instance ...
    
        ' Create DirectDraw instance
        DirectDrawCreate ByVal 0&, G_oDDInstance, Nothing

        ' Check instance existance, terminate if missing
        If G_oDDInstance Is Nothing Then
           AppError 0, "Could not create DirectDraw instance", "AppInitialize"
           Exit Sub
        End If
         
        ' Set cooperation mode of DirectX
        
        G_oDDInstance.SetCooperativeLevel fMain.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN
        
        ' Set display mode
        G_oDDInstance.SetDisplayMode 640, 480, 16
           
    ' Initialize primary surface ...
    
        ' Initialize primary surface description
        With L_dDDSD
            ' Get Structure size
            .dwSize = Len(L_dDDSD)
            ' Structure uses Surface Caps and count of BackBuffers
            .dwFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
            ' Structure describes a flippable (buffered) surface
            .DDSCAPS.dwCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_SYSTEMMEMORY
            ' Structure uses one BackBuffer
            .dwBackBufferCount = 1
         End With
    
        ' Create primary surface from structure
        G_oDDInstance.CreateSurface L_dDDSD, G_oDDPrimary, Nothing
    
        ' Check primary existance, terminate if missing
        If G_oDDPrimary Is Nothing Then
           AppError 0, "Could not create primary surface", "AppInitialize"
           Exit Sub
        End If
    
    ' Initialize backbuffer from primary ...
    
        ' Set surface description to backbuffer creation
        L_dDDSD.dwFlags = DDSD_CAPS
        L_dDDSD.DDSCAPS.dwCaps = DDSCAPS_BACKBUFFER
        
        ' Create backbuffer from frontbuffer
        G_oDDPrimary.GetAttachedSurface L_dDDSD.DDSCAPS, G_oDDBackbuffer
        
        ' Check backbuffer existance, terminate if missing
        If G_oDDBackbuffer Is Nothing Then
           AppError 0, "Could not create backbuffer", "AppInitialize"
           Exit Sub
        End If
        

    ' Initialize sound system ...
    
        ' Create an instance of DirectSound interface
        DirectSoundCreate ByVal 0&, G_oDSInstance, Nothing
            
        ' Check instance existance, terminate if missing
        If G_oDSInstance Is Nothing Then
           AppError 0, "Could not create DirectSound instance", "AppInitialize"
           Exit Sub
        End If
                    
        ' Set sound system cooperative level
        G_oDSInstance.SetCooperativeLevel fMain.hWnd, DSSCL_NORMAL
        
    ' Initialize background music
        Set G_oDSBufferMusic = LoadWaveIntoDSB(App.Path + "\music.wav")
        G_oDSBufferMusic.Play ByVal 0&, ByVal 0&, DSBPLAY_LOOPING
        
    ' Initialize windows for displaying various effects
        Call CreateWindows
            
    ' Initialize Direct3DRM interface instance ...
    
        ' Create Direct3DRM instance
        Direct3DRMCreate G_oD3DInstance
    
        ' Check instance existance, terminate if missing
        If G_oD3DInstance Is Nothing Then
           AppError 0, "Could not create D3DRM instance", "AppInitialize"
           Exit Sub
        End If
    
    ' Initialize Direct3DRM driver ...
    
        ' Get a Direct3D immediate object from the existing DirectDraw object
        Set L_oD3DIM = G_oDDInstance
    
        ' Set error handler to local for enumeration only
        On Error Resume Next
        
        ' Start the callback that does the driver enumeration
        L_oD3DIM.EnumDevices AddressOf EnumDeviceCallback, 0
    
        ' Catch any error resulting from the enumeration and terminate
        If Err.Number > 0 Then
           AppError Err.Number, Err.Description, "AppInitialize"
           Exit Sub
        End If
    
        ' Reset error handler to default
        On Error GoTo E_AppInitialize
        
        ' Reset Direct3D immediate object
        Set L_oD3DIM = Nothing
        
        ' Check if a convenient device driver has been found, terminate if no driver available
        If Not G_bD3DDriverPresent Then
           AppError 0, "Could not detect Direct3D device driver", "AppInitialize"
           Exit Sub
        End If
        
    ' Initialize D3DRM display system
    
        ' Create a D3DRM device from the 3D buffer
        G_oD3DInstance.CreateDeviceFromSurface G_dD3DDriver.GUID, G_oDDInstance, G_dDDWindow(0).oDDSurface, G_oD3DDevice
        
        ' Check device existance, terminate if missing
        If G_oD3DDevice Is Nothing Then
           AppError 0, "Could not create D3DRM device", "AppInitialize"
           Exit Sub
        End If
    
        ' Set D3DRM device quality
        G_oD3DDevice.SetQuality D3DRMLIGHT_ON Or D3DRMFILL_SOLID Or D3DRMSHADE_PHONG
        
        ' Create the master frame containing all other frames
        G_oD3DInstance.CreateFrame Nothing, G_oD3DMasterFrame
        
        ' Create the camera frame containing the primary camera
        G_oD3DInstance.CreateFrame G_oD3DMasterFrame, G_oD3DCameraFrame
        
        ' Create a D3D viewport from the device, using the camera frame for output
        G_oD3DInstance.CreateViewport G_oD3DDevice, G_oD3DCameraFrame, 0, 0, 280, 200, G_oD3DViewport
            
        ' Check viewport existance, terminate if missing
        If G_oD3DViewport Is Nothing Then
           AppError 0, "Could not create D3DRM viewport", "AppInitialize"
           Exit Sub
        End If
            
        
    ' Initialize scene and display settings ...
            
        Call CreateScene
        
        ' Create character fontset and objects
        Call CreateChars
        
        ' Create textured and animated ground
        Call CreateGround
        
        ' Create mirror effect
        Call CreateMirror
        
        ' Create decal fire
        Call CreateFlames
        
        ' Create rotor object
        Call CreateRotor
        
        ' Create background animation
        Call CreateBack
        
        ' Error handling ...
        
        Exit Sub

E_AppInitialize:

        AppError Err.Number, Err.Description, "AppInitialize"
        
End Sub

Public Sub AppLoop()

    ' Enable error handling
        On Error GoTo E_AppLoop

    ' Setup local variables...
        Dim L_nNextFrameTime As Long        ' Timer used to time frames to a minimum duration
        Dim L_nFrameCount As Long           ' Frame counter used for calculating average framerate
        Dim L_nNextSecond As Long           ' TimeGetTime value above which next second begins
        Dim L_nCurrentTime As Long          ' Time at start of frame, to avoid multiple calls of TimeGetTime
        
        Dim L_dRenderArea As RECT           ' Rectangle to describe render area for blitting
        Dim L_dDDBLTFX As DDBLTFX           ' Holds F/X settings for blitting
        
    ' Preparations for master loop
    
        ' Prepare BLTFX structure for color fill blit to clear backbuffer
        With L_dDDBLTFX
            .dwSize = Len(L_dDDBLTFX)
            .dwFillColor = 0
        End With
        
    ' Master loop controlling application behavior...
        
        Do
            
            ' Do frame timing and statistics ...
            
                ' Increase global frame counter
                G_nFrameCount = G_nFrameCount + 1
                
                ' Get frame start time
                L_nCurrentTime = timeGetTime
                
                ' Increase frame count for avg frametime calculation
                L_nFrameCount = L_nFrameCount + 1
                
                ' Protocol frame time: Count frames and write out average frame count every second
                If L_nNextSecond < L_nCurrentTime Then
                    G_nFrameAvg = (G_nFrameAvg + L_nFrameCount) / 2
                    L_nNextSecond = L_nCurrentTime + 1000
                    L_nFrameCount = 0
                End If
            
                ' Prepare timing: Set next frame time to current time plus minimum frame duration (15fps , makes for ~60ms)
                L_nNextFrameTime = L_nCurrentTime + 50
            
                ' Query user input
                DoEvents
                        
            ' Clear backbuffer ...
                
                ' FX-Blit filling background with black
                With L_dRenderArea
                    .Top = 0
                    .Left = 0
                    .Bottom = 480
                    .Right = 640
                End With
                G_oDDBackbuffer.Blt L_dRenderArea, ByVal Nothing, ByVal 0&, DDBLT_COLORFILL, L_dDDBLTFX
            
            ' Do updating for background animation
                Call UpdateBack
                
            ' Do updating for animated Lava ...
                 If G_nFrameCount Mod 2 = 0 Then Call UpdateGround
                
            ' Update D3DRM only if within active time segment ...
            
                If (G_nFrameCount Mod 150) < 100 Then
                
                    ' Do flame decal updating ...
                         Call UpdateFlames
                        
                    ' Do mirror updating ...
                         If G_nFrameCount Mod 2 = 0 Then Call UpdateMirror
                        
                    ' Do updating for D3DRM scene ...
                         Call UpdateScene
                         
                End If
            
                ' Update status text describing current state of D3DRM window
                With L_dRenderArea
                    .Top = IIf((G_nFrameCount Mod 150) < 100, 0, 1) * 10
                    .Left = 0
                    .Right = 110
                    .Bottom = .Top + 10
                End With
                G_dDDWindow(0).oDDSurface.BltFast 165, 185, G_oDDSurfaceStatus, L_dRenderArea, DDBLTFAST_NOCOLORKEY
                
            ' Update display system ...
               Call UpdateWindows
                                
            ' Do updating of moving characters ...
               Call UpdateChars
                
            ' Flip DirectX buffers...
                G_oDDPrimary.Flip Nothing, 0
                
            ' Do timing: Loop until minimum time per frame reached ...
            Do
            Loop Until timeGetTime > L_nNextFrameTime
        
        Loop
        
    ' Error handling ...
    
        Exit Sub

E_AppLoop: