bdirectx.cls

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

'-============================================================
' AmbientLight
'-============================================================
Public Function AmbientLight() As Direct3DRMLight
    Set AmbientLight = m_rmAmbientLight
End Function
 
 
'-============================================================
' Use3DHardware
'-============================================================
Property Let Use3DHardware(b As Boolean)
    m_bUseSoftwareOnly = Not b
End Property

Property Get Use3DHardware() As Boolean
    Use3DHardware = Not m_bUseSoftwareOnly
End Property
'-============================================================
' UseBackBuffer
'-============================================================
Property Let UseBackBuffer(b As Boolean)
    m_bCreateFromClipper = Not b
End Property

Property Get UseBackBuffer() As Boolean
    UseBackBuffer = Not m_bCreateFromClipper
End Property
'-============================================================
' DirectDrawGuid
'-============================================================
Property Get DirectDrawGuid() As String
     DirectDrawGuid = m_strDDGuid
End Property
'-============================================================
' Direct3DGuid
'-============================================================
Property Get Direct3DGuid() As String
     Direct3DGuid = m_strD3DGuid
End Property

'- Runtime only List Functions
'
'-============================================================
' Devices
'-============================================================
Public Function Devices(Optional ddrawguid = "") As Direct3DEnumDevices
    On Local Error GoTo exitOut:
    
    Dim dd As DirectDraw7
    Dim d3d As Direct3D7
    
    Set dd = dx.DirectDrawCreate(CStr(ddrawguid))
        
    Set d3d = dd.GetDirect3D()
    
    Set Devices = d3d.GetDevicesEnum()
    
    Set dd = Nothing
    Set d3d = Nothing
    Exit Function
    
exitOut:

End Function

'-============================================================
' VideoCards
'-============================================================
Public Function VideoCards() As DirectDrawEnum
    Set VideoCards = m_dx.GetDDEnum()
End Function

'-============================================================
' DisplayModes
'-============================================================
Public Function DisplayModes(Optional ddrawguid = "") As DirectDrawEnumModes
    On Local Error GoTo exitOut
    Dim dd As DirectDraw4
    Set dd = dx.DirectDraw4Create(CStr(ddrawguid))
    Dim ddsd As DDSURFACEDESC2
    Set DisplayModes = dd.GetDisplayModesEnum(0, ddsd)
    Set dd = Nothing
exitOut:
End Function
'-============================================================
' IsFullScreen
'-============================================================
Property Get IsFullScreen() As Boolean
    IsFullScreen = m_bfullscreen
End Property
'-============================================================
' FPS
'-============================================================
Public Property Get FPS() As Single
    FPS = m_fps
End Property
'-============================================================
' Render
'-============================================================
Public Sub Render()
    On Local Error GoTo errout
    If m_binit = False Then Exit Sub
    
    Dim t As Long
    Dim delta As Single
    Static fcount As Long
    
    t = dx.TickCount()
    
    m_rmViewport.Clear D3DRMCLEAR_ZBUFFER Or D3DRMCLEAR_TARGET
    
    ' clear Rect
    ClearRec(0).X1 = m_rmViewport.GetX
    ClearRec(0).Y1 = m_rmViewport.GetY
    ClearRec(0).X2 = m_rmViewport.GetWidth
    ClearRec(0).Y2 = m_rmViewport.GetHeight
    ' calculate the Background X to display
    bakm = (6.28 - Angle) / 6.28 * m_rmViewport.GetWidth * 2
    If bakm > m_rmViewport.GetWidth * 2 Then bakm = m_rmViewport.GetWidth * 2
    If bakm < 0 Then bakm = 0
    ' display the part of the background
     m_backBuffer.Blt REC(0, 0, 0, 0), Background, REC(bakm, 0, bakm + m_rmViewport.GetWidth / 2, m_rmViewport.GetHeight), DDBLT_WAIT
    
     m_rmViewport.Render m_rmFrameScene
     RaiseEvent PostRender

     m_rmDevice.Update
    
     If m_bfullscreen Then
        m_frontBuffer.Flip Nothing, DDFLIP_WAIT
    Else
        If m_bCreateFromClipper = False Then
           Call m_dx.GetWindowRect(m_hwnd, wndr)
           m_frontBuffer.Blt wndr, m_backBuffer, m_emptyrect, DDBLT_WAIT
        End If
    End If
    fcount = fcount + 1
    If fcount = 30 Then
        t = dx.TickCount()
        m_fps = 30000 / (t - m_lastFPS)
        fcount = 0
        m_lastFPS = t
    End If
    
errout:
End Sub
'-============================================================
' hwnd
'-============================================================
Public Property Let hwnd(handle As Long)
    m_hwnd = handle
End Property
Public Sub Resize(w As Long, h As Long)
    On Local Error Resume Next
    
    Dim b As Boolean
    
    If m_binit = False Then
        Exit Sub
    End If
    
    'full screen apps shouldnt resize
    If m_bfullscreen Then Exit Sub
    
    SaveDeviceViewportCharacteristics
   
    If Not m_bUseSoftwareOnly Then
        b = InitWindowed(m_strDDGuid, "IID_IDirect3DHALDevice")
    End If
    If Not b Then
       b = InitWindowed(m_strDDGuid, "IID_IDirect3DRGBDevice")
    End If
    
    RestoreDeviceViewportCharacteristics
    
End Sub

'-============================================================
' Class_Initialize
'-============================================================
Private Sub class_Initialize()
    Dim b As Boolean
    
    m_bCreateFromClipper = True
    
    b = InitSceneGraph()
    If Not b Then
        RaiseEvent DirecXNotInstalled
        Exit Sub
    End If
End Sub

'-============================================================
' Class_Terminate
'-============================================================
Private Sub Class_Terminate()
    Cleanup
    CleanupRMObjects
    Set DSOUND70 = Nothing
    Set DsoundPri70 = Nothing
    Set DsoundLis70 = Nothing
End Sub

'-============================================================
' Cleanup objects that can hold onto vmem
'-============================================================
Private Sub Cleanup()
    Err.Clear
    On Local Error Resume Next
    m_dd.RestoreDisplayMode
    m_dd.SetCooperativeLevel m_hwnd, DDSCL_NORMAL
    Set m_backBuffer = Nothing
    Set m_frontBuffer = Nothing
    Set m_dd = Nothing
    Set m_ddClip = Nothing
    Set m_rmViewport = Nothing
    Set m_rmDevice = Nothing
    m_bfullscreen = False
    m_binit = False
End Sub

'-============================================================
' Cleanup rest of RM objects
'-============================================================
Private Sub CleanupRMObjects()
    Set m_rmFrameCamera = Nothing
    Set m_rmFrameScene = Nothing
    Set m_rmFrameDirLight = Nothing
    Set m_rmFrameAmbientLight = Nothing
    Set m_rmDirLight = Nothing
    Set m_rmAmbientLight = Nothing
End Sub
'-====================================================
' RestoreDeviceViewportCharacteristics
'
' when the viewport is destroyed for whatever reason (resize)
' this function allows us to retain the characteristics
' of the viewport we just destroyed
'-====================================================
Private Sub RestoreDeviceViewportCharacteristics()
    With m_DevInfo
        m_rmDevice.SetDither .bDither
        m_rmDevice.SetName .Name
        m_rmDevice.SetQuality .Quality
        m_rmDevice.SetRenderMode .RenderMode
        m_rmDevice.SetShades .Shades
        m_rmDevice.SetTextureQuality .TexQ
    End With
    With m_ViewInfo
        m_rmViewport.SetBack .Back
        m_rmViewport.SetField .Field
        m_rmViewport.SetFront .Front
        m_rmViewport.SetName .Name
        m_rmViewport.SetProjection .Projection
        m_rmViewport.SetPlane .left, .right, .bottom, .top
        m_rmViewport.SetUniformScaling .scaling
    End With
End Sub
'-====================================================
' SaveDeviceViewportCharacteristics
'
' we need to retain certain characteristics about the
' viewport and device so that they look the same
' when recreated after a resize
'-====================================================
Private Sub SaveDeviceViewportCharacteristics()
    
    With m_DevInfo
        .bDither = m_rmDevice.GetDither
        .Name = m_rmDevice.GetName
        .Quality = m_rmDevice.GetQuality
        .RenderMode = m_rmDevice.GetRenderMode
        .Shades = m_rmDevice.GetShades
        .TexQ = m_rmDevice.GetTextureQuality
        .WFoptions = m_rmDevice.GetWireframeOptions
    End With
    With m_ViewInfo
        .Back = m_rmViewport.GetBack
        .Field = m_rmViewport.GetField
        .Front = m_rmViewport.GetFront
        .Name = m_rmViewport.GetName
        .Projection = m_rmViewport.GetProjection
        .scaling = m_rmViewport.GetUniformScaling
        m_rmViewport.GetPlane .left, .right, .bottom, .top
        
    End With
End Sub
'-====================================================
' SetDeviceDefaults
'-====================================================
Private Sub SetDeviceDefaults()
    m_rmDevice.SetQuality D3DRMRENDER_GOURAUD
End Sub
'-====================================================
' InitSceneGraph
'
' create default lighting and cameras
'-====================================================
Private Function InitSceneGraph() As Boolean
    On Local Error GoTo errout
    'create a skeletal scene graph
    Set m_rm = m_dx.Direct3DRMCreate()
    Set m_rmFrameScene = m_rm.CreateFrame(Nothing)
    Set m_rmFrameCamera = m_rm.CreateFrame(m_rmFrameScene)
    m_rmFrameCamera.SetPosition Nothing, 0, 0, -10
    
    'create a bright directional light
    Set m_rmFrameDirLight = m_rm.CreateFrame(m_rmFrameScene)
    Set m_rmDirLight = m_rm.CreateLightRGB(D3DRMLIGHT_DIRECTIONAL, 1, 1, 1)
    
    'create a dull ambient light
    Set m_rmAmbientLight = m_rm.CreateLightRGB(D3DRMLIGHT_AMBIENT, 0.2, 0.2, 0.2)
    
    'add the lights to the scene graph
    m_rmFrameDirLight.AddLight m_rmDirLight
    m_rmFrameScene.AddLight m_rmAmbientLight
    m_rmFrameDirLight.SetPosition Nothing, 5, 5, -5
    m_rmFrameDirLight.LookAt m_rmFrameScene, Nothing, 0
       
    InitSceneGraph = True
    Exit Function
errout:
    InitSceneGraph = False
End Function
'-============================================================
' GetBoundingBox
'-============================================================
Public Sub GetBoundingBox(frame As Direct3DRMFrame3, ByRef xmin As Single, ByRef ymin As Single, ByRef zmin As Single, ByRef xMax As Single, ByRef yMax As Single, ByRef zmax As Single)
    Dim box1 As D3DRMBOX
    Dim mb As Direct3DRMMeshBuilder3
    
    Set mb = m_rm.CreateMeshBuilder()
    mb.AddFrame frame
    
    mb.GetBox box1
    
    xmin = box1.Min.x
    ymin = box1.Min.y
    zmin = box1.Min.z
    
    xMax = box1.Max.x
    yMax = box1.Max.y
    zmax = box1.Max.z
        
End Sub
Public Function CreateSheetMesh(nSides As Integer, Height As Single, Width As Single, TU As Single, TV As Single) As Direct3DRMMeshBuilder3

    Dim m As Direct3DRMMeshBuilder3
    Dim f As Direct3DRMFace2
    Set m = m_rm.CreateMeshBuilder()
        
    Dim dx  As Single
    Dim dy  As Single
    dy = Height / 2
    dx = Width / 2
    
    'Front Face
    Set f = m_rm.CreateFace()
    f.AddVertex dx, dy, 0
    f.AddVertex dx, -dy, 0
    f.AddVertex -dx, -dy, 0
    f.AddVertex -dx, dy, 0
    m.AddFace f
    
    m.SetTextureCoordinates 3, 0, 0
    m.SetTextureCoordinates 2, 0, TV
    m.SetTextureCoordinates 1, TU, TV
    m.SetTextureCoordinates 0, TU, 0
    
    
    If nSides > 1 Then
        'Back Face
        Set f = m_rm.CreateFace()
        f.AddVertex -dx, dy, 0
        f.AddVertex -dx, -dy, 0
        f.AddVertex dx, -dy, 0
        f.AddVertex dx, dy, 0
        m.AddFace f
    
        m.SetTextureCoordinates 7, 0, 0
        m.SetTextureCoordinates 6, 0, TV
        m.SetTextureCoordinates 5, TU, TV
        m.SetTextureCoordinates 4, TU, 0
    
    End If
    
    Set CreateSheetMesh = m

End Function
Public Function CreateDDSFromBMP4(Sfile As String, Optional SWidth As Long, Optional Sheight As Long, Optional Memoryusage As MemoryAlloc) As DirectDrawSurface4
    On Local Error GoTo errout
    
    Attemtstr = "Creating DirectdrawSurface From Bitmap " + Sfile
    
    Dim ddsd As DDSURFACEDESC2
    ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    If Memoryusage = USESYSTEMMEMORY Then
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
    Else
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
    End If
    ddsd.lWidth = SWidth
    ddsd.lHeight = Sheight
    If Sfile <> "" Then
        Set CreateDDSFromBMP4 = m_dd.CreateSurfaceFromFile(Sfile, ddsd)
    Else
        Set CreateDDSFromBMP4 = m_dd.CreateSurface(ddsd)
    End If
    
errout:
    RaiseEvent Error4("Error in " + Attemt)
End Function
Private Function CreateDDSFromCDIB4(cDib As cDIBSection, Optional SWID As Long, Optional SHei As Long, Optional Memoryusage As MemoryAlloc) As DirectDrawSurface4
    Dim ddsd As DDSURFACEDESC2
    Dim dds As DirectDrawSurface4
    Dim hdcSurface As Long
    Dim TMPDIB As cDIBSection
    
    If SWID = 0 Then
        SWID = cDib.Width
    End If
    If SHei = 0 Then
        SHei = cDib.Height
    End If
    
    With ddsd
        .lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
        .lWidth = SWID
        .lHeight = SHei
    End With
    If Memoryusage = USESYSTEMMEMORY Then
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
    Else
        ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
    End If
    
    Set dds = m_dd.CreateSurface(ddsd)
    dds.restore
    hdcSurface = dds.GetDC
    Set TMPDIB = cDib.Resample(SHei, SWID)
    TMPDIB.PaintPicture hdcSurface
    dds.ReleaseDC hdcSurface
    
    Set TMPDIB = Nothing
    Set CreateDDSFromCDIB4 = dds
    Set dds = Nothing
End Function
Public Function CreateDDSFromCDIBFILE4(file As String, Optional SWID As Long, Optional SHei As Long, Optional Memoryusage As MemoryAlloc) As DirectDrawSurface4
    On Local Error GoTo errout
    Attemtstr = "Creating DirectdrawSurface From FILE " + file
    
    Dim cDib As New cDIBSection
    cDib.CreateFromPicture LoadPicture(file)
    Set CreateDDSFromCDIBFILE4 = CreateDDSFromCDIB4(cDib, SWID, SHei, Memoryusage)
    Set cDib = Nothing
    
    Exit Function
errout:
    RaiseEvent Error4("Error in " + Attemt)
End Function