mmain.bas

一个d3d实例程序

     
        ' Clean up all DirectX objects
        Set L_oD3DMeshbuilder = Nothing
    
    ' Error handling ...
    
        Exit Sub

E_CreateMirror:
    
        AppError Err.Number, Err.Description, "CreateMirror"
    
End Sub


Private Sub UpdateChars()

    ' Enable error handling ...
        
        On Error GoTo E_UpdateChars
    
    ' Setup local variables ...
        
        Dim L_dRenderArea As RECT           ' Variable holding blitting area
        Dim L_nRunChar As Integer           ' Variable to run through all characters to be displayed
        Dim L_nRunRow As Integer            ' Variable to run through rows within a character
        Dim L_nRunCol As Integer            ' Variable to run through columns within a character
        Dim L_dDDBLTFX As DDBLTFX           ' FX descriptor for blitting
        Dim L_nColorFactor As Long          ' Color factor for blitting characters
        
    ' Update scrolling characters ...
        
        ' Scroll text
        G_nCharScrollPos = G_nCharScrollPos + 5
        
        ' If offset of one character reached
        If G_nCharScrollPos > 36 Then
            
            ' Reset offset
            G_nCharScrollPos = 0
            
            ' Scroll text
            G_sDisplayText = Right(G_sDisplayText, Len(G_sDisplayText) - 1) + Left(G_sDisplayText, 1)
            
            ' Rebuild surface holding characters ...
            
                ' Clear surface
                With L_dDDBLTFX
                    .dwFillColor = 0
                    .dwSize = Len(L_dDDBLTFX)
                End With
                With L_dRenderArea
                    .Top = 0
                    .Left = 0
                    .Bottom = 47
                    .Right = 520
                End With
                G_oDDSurfaceChars.Blt L_dRenderArea, ByVal Nothing, ByVal 0&, DDBLT_COLORFILL, L_dDDBLTFX
                
                ' Draw characters...
                
                ' Run through all characters, and through rows and columns of the characters
                For L_nRunChar = 0 To 12
                    For L_nRunRow = 0 To 6
                        For L_nRunCol = 0 To 4
                            
                            ' If the font data set tells that a pixel is to be drawn
                            If G_bFontData(Asc(Mid(G_sDisplayText, L_nRunChar + 1, 1)), L_nRunRow * 5 + L_nRunCol) Then
                                
                                ' Set fillcolor according to row position
                                L_nColorFactor = (31 - 5 * Abs(3 - L_nRunRow))
                                L_dDDBLTFX.dwFillColor = L_nColorFactor * 1024 + L_nColorFactor * 32 + L_nColorFactor
                                
                                ' Set render area according to current position
                                With L_dRenderArea
                                    .Top = L_nRunRow * 7
                                    .Bottom = .Top + 5
                                    .Left = L_nRunChar * 40 + L_nRunCol * 7
                                    .Right = .Left + 5
                                End With
                                
                                ' Blit to character surface
                                G_oDDSurfaceChars.Blt L_dRenderArea, ByVal Nothing, ByVal 0&, DDBLT_COLORFILL, L_dDDBLTFX
                                
                            End If
                            
                        Next
                    Next
                Next

        End If
        
        With L_dRenderArea
            .Top = 0
            .Left = G_nCharScrollPos
            .Bottom = .Top + 47
            .Right = .Left + 480
        End With
        G_oDDBackbuffer.BltFast G_dDDWindow(1).nX, G_dDDWindow(1).nY, G_oDDSurfaceChars, L_dRenderArea, DDBLTFAST_SRCCOLORKEY
        
    ' Error handler ...
        Exit Sub
    
E_UpdateChars:

    AppError Err.Number, Err.Description, "UpdateChars"

End Sub

Private Sub UpdateWindows()

    ' Enable error handling ...
        
        On Error GoTo E_UpdateWindows

    ' Setup local variables ...
        
        Dim L_nRunWindows As Integer      ' Variable to run through all windows
        
    ' Update all windows that are activated ...
    
        For L_nRunWindows = 0 To 2
            With G_dDDWindow(L_nRunWindows)
            
                ' Update window position
                .nX = .nX + .nDX
                .nY = .nY + .nDY

                ' Reflect window on edges
                With G_dDDWindow(L_nRunWindows)
                    If .nY > 470 - (.dRenderArea.Bottom - .dRenderArea.Top) Then .nDY = -.nDY
                    If .nY < 10 Then .nDY = -.nDY
                    If .nX > 630 - (.dRenderArea.Right - .dRenderArea.Left) Then .nDX = -.nDX
                    If .nX < 10 Then .nDX = -.nDX
                 End With
                                     
                ' Redraw window contents
                If Not (G_dDDWindow(L_nRunWindows).oDDSurface Is Nothing) Then
                    G_oDDBackbuffer.BltFast .nX, .nY, .oDDSurface, .dRenderArea, DDBLTFAST_SRCCOLORKEY
                End If
                
            End With
        Next
        
    ' Error handler ...
        Exit Sub
    
E_UpdateWindows:

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

    

Private Sub UpdateGround()

    ' Enable error handling ...
        
        On Error GoTo E_UpdateGround
    
    ' Setup local variables ...
        
        Dim L_nSeperator As Integer           ' Holds current scroll seperator position
        Dim L_dRenderArea As RECT             ' Variable holding blitting area
        
    ' Update scrolling lava texture
    
        ' Render current phase to surface the texture is attached to
        L_nSeperator = 32 - (G_nFrameCount Mod 32)
        With L_dRenderArea
            .Top = 0
            .Left = 0
            .Bottom = L_nSeperator
            .Right = 32
        End With
        If L_nSeperator > 1 Then G_oDDSurfaceLava.BltFast 0, 32 - L_nSeperator, G_oDDResourceLava, L_dRenderArea, DDBLTFAST_NOCOLORKEY
        With L_dRenderArea
            .Top = L_nSeperator + 1
            .Left = 0
            .Bottom = 32
            .Right = 32
        End With
        If L_nSeperator < 31 Then G_oDDSurfaceLava.BltFast 0, 0, G_oDDResourceLava, L_dRenderArea, DDBLTFAST_NOCOLORKEY
            
        ' Inform D3DRM that the surface the texture is attached to has changed
        G_oD3DTextureLava.Changed 1, 0

    ' Error handler ...
        Exit Sub
    
E_UpdateGround:

        AppError Err.Number, Err.Description, "UpdateGround"

End Sub

Private Sub UpdateFlames()

    ' Enable error handling ...
        
        On Error GoTo E_UpdateFlames
    
    ' Setup local variables ...
        Dim L_dRenderArea As RECT       ' Variable holding blitting area

        ' Update flame lighting #1
        G_oD3DLightFlame1.SetConstantAttenuation 0.5 + Rnd

        ' Update texture for flame #1
        With L_dRenderArea
            .Left = ((G_nFrameCount / 2) Mod 4) * 32
            .Top = Int(((G_nFrameCount / 2) Mod 16) / 4) * 32
            .Bottom = .Top + 32
            .Right = .Left + 32
        End With
        G_oDDSurfaceFlame1.BltFast 0, 0, G_oDDResourceFlame, L_dRenderArea, DDBLTFAST_NOCOLORKEY
    
        ' Inform D3DRM that the surface the texture is attached to has changed
        G_oD3DTextureFlame1.Changed 1, 0
        
        ' Update flame lighting #2
        G_oD3DLightFlame2.SetConstantAttenuation 0.5 + Rnd
        
        ' Update texture for flame #2
        With L_dRenderArea
            .Left = ((G_nFrameCount / 2) Mod 4) * 32
            .Top = Int(((G_nFrameCount / 2) Mod 16) / 4) * 32
            .Bottom = .Top + 32
            .Right = .Left + 32
        End With
        G_oDDSurfaceFlame2.BltFast 0, 0, G_oDDResourceFlame, L_dRenderArea, DDBLTFAST_NOCOLORKEY
    
        ' Inform D3DRM that the surface the texture is attached to has changed
        G_oD3DTextureFlame2.Changed 1, 0

    ' Error handler ...
        Exit Sub
    
E_UpdateFlames:

        AppError Err.Number, Err.Description, "UpdateFlames"

End Sub

Private Sub UpdateScene()

    ' Enable error handling ...
        
        On Error GoTo E_UpdateScene
    
    ' Setup local variables ...

        ' Set the new camera position from the lookup table, loop position within lookup table
        G_nCamPosCurrent = G_nCamPosCurrent + 1
        If G_nCamPosCurrent > 179 Then G_nCamPosCurrent = 0
        
        ' Set camera position and orientation to new values
        With G_dCamPosLookup(G_nCamPosCurrent)
            G_oD3DCameraFrame.SetPosition Nothing, .X, .Y, .z
            G_oD3DCameraFrame.SetOrientation Nothing, 11 - .X, 10.5 - .Y, -4, 0, 0, 1
        End With
    
        ' Update D3DRM model
        G_oD3DInstance.Tick 1
        
    ' Error handler ...
        Exit Sub
    
E_UpdateScene:

        AppError Err.Number, Err.Description, "UpdateScene"

End Sub

Private Sub UpdateMirror()

    ' Enable error handling ...
        
        On Error GoTo E_UpdateMirror
    
    ' Update mirror animation ...
        
        ' Inform the renderer that the texture has changed
        G_oD3DTextureMirror.Changed 1, 0
        
    ' Error handler ...
        Exit Sub
    
E_UpdateMirror:

        AppError Err.Number, Err.Description, "UpdateMirror"

End Sub


Private Sub UpdateBack()

    ' Enable error handling...
        On Error GoTo E_UpdateBack

    ' Setup local variables ...
            
        Dim L_dDDSD As DDSURFACEDESC    ' Description of surface to be obtained by lock
        Dim L_nSurfacePointer As Long   ' Pointer to the surface
        Dim L_nRun As Integer           ' Variable to run through arrays
        Dim L_dRenderArea As RECT       ' Area to render explosions from
        
    ' Update background stars ...
    
        ' Prepare structure to obtain lock
        L_dDDSD.dwSize = Len(L_dDDSD)
        L_dDDSD.dwFlags = DDSD_LPSURFACE

        ' Obtain lock to surface
        G_oDDBackbuffer.Lock ByVal 0&, L_dDDSD, DDLOCK_SURFACEMEMORYPTR, ByVal 0&
            
        ' Get pointer to surface memory
        L_nSurfacePointer = L_dDDSD.lpSurface
        
        ' Calculate and draw stars ...
        For L_nRun = 0 To 1999
            With G_dStar(L_nRun)
                
                .nX = .nX - .nSpeed
                If .nX < 5 Then .nX = 635
                
                CopyMemory ByVal (L_nSurfacePointer + .nX * 2 + .nY * 1280), ByVal VarPtr(.nColor), 2
                
            End With
        Next
        
        ' Release lock to surface
        G_oDDBackbuffer.Unlock ByVal 0&
        
    ' Update background explosions ...
    
        For L_nRun = 0 To 14
            With G_dExplo(L_nRun)
                    
                ' Calculate new position and phase
                .nPhase = .nPhase + 1
                .nX = .nX - 3
                
                ' Spawn new explosion if old one off screen or finished ...
                If .nPhase > 15 Or .nX < 3 Then
                    
                    ' Set visual data
                    .nPhase = 0
                    .nX = Int(Rnd * 600) + 5
                    .nY = Int(Rnd * 470) + 5
                    
                    ' Set sound effect for first 8 explosions ...
                    If L_nRun < 8 Then
                        
                        ' Stop if still playing
                        .oDSBuffer.Stop
                        
                        ' Alter frequency randomly, resulting in various pitch
                        .oDSBuffer.SetFrequency ByVal Int(Rnd * 35000) + 15000
                        
                        ' Set pan to fit position , resulting in stereo effect
                        .oDSBuffer.SetPan (320 - .nX) * 10
                        
                        ' Alter volume randomly, resulting in distinguishable explosions
                        .oDSBuffer.SetVolume ByVal (-300 - Int(Rnd * 400))
                        
                        ' Restart sound
                        .oDSBuffer.Play ByVal 0&, ByVal 0&, ByVal 0&
                        
                    End If
                    
                End If
                
                ' Calculate render area, clip at edges
                L_dRenderArea.Top = 0
                L_dRenderArea.Left = .nPhase * 32 + IIf(.nX < 32, 32 - .nX, 0)
                L_dRenderArea.Right = L_dRenderArea.Left + IIf(.nX < 32, .nX, 32)
                L_dRenderArea.Bottom = L_dRenderArea.Top + IIf(480 - .nY < 32, 480 - .nY, 32)
                
                ' Blit explosion to backbuffer
                G_oDDBackbuffer.BltFast .nX, .nY, G_oDDSurfaceExplo, L_dRenderArea, DDBLTFAST_SRCCOLORKEY
                
            End With
        Next
        
    ' Error handling ...
    
        Exit Sub

E_UpdateBack:

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

End Sub