bdirectx.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "BDirectx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit

Public Event DirecXNotInstalled()
Public Event PostRender()
Public Event Error4(Errstr As String)
Public Event Attemt4(Attemtstr As String)

Private Type DeviceCharacteristics
    bDither As Long
    Name As String
    Quality As Long
    RenderMode As Long
    Shades As Long
    TexQ As Long
    WFoptions As Long
End Type

Private Type ViewportCharacteristics
    Back As Single
    Field As Single
    Front As Single
    Name As String
    Projection As Long
    left As Single
    right As Single
    bottom As Single
    top As Single
    scaling As Long
End Type

'- direct x object
Dim m_dx As New DirectX7

'- direct draw objects
Dim m_dd As DirectDraw4
Dim m_ddClip As DirectDrawClipper
Dim m_frontBuffer As DirectDrawSurface4
Dim m_backBuffer As DirectDrawSurface4

'- direct 3drm objects
Dim m_rm As Direct3DRM3
Dim m_rmDevice As Direct3DRMDevice3
Dim m_rmViewport As Direct3DRMViewport2
Dim m_rmFrameScene As Direct3DRMFrame3
Dim m_rmFrameCamera As Direct3DRMFrame3
Dim m_rmFrameDirLight As Direct3DRMFrame3
Dim m_rmFrameAmbientLight As Direct3DRMFrame3
Dim m_rmDirLight As Direct3DRMLight
Dim m_rmAmbientLight As Direct3DRMLight


'- state
Dim m_strDDGuid As String               'DirectDraw device guid
Dim m_strD3DGuid As String              'Direct3DRM device guid
Dim m_hwnd As Long                      'hwnd (either FSWindow or our ocx)
Dim m_binit As Boolean                  'are we initailized?
Dim m_lastFPS As Long                   'time stamp of last FPS update
Dim m_fps As Single                     'frame per second
Dim m_bCreateFromClipper As Boolean     'Use a clipper to start the RM
Dim m_DevInfo As DeviceCharacteristics
Dim m_ViewInfo As ViewportCharacteristics
Dim m_bfullscreen As Boolean
Dim m_bUseSoftwareOnly As Boolean
Dim Attemt As String
Dim m_emptyrect As RECT
Dim wndr As RECT


Dim NoEdgeW As DDCOLORKEY
Dim hud As DirectDrawSurface4
Dim Stretching As DDSURFACEDESC2
Dim hudWidth
Dim hudHeight
Dim hudAttributes As RECT
Dim hudX As Integer
Dim hudY As Integer

'Directsoundinner
Public DSOUND70 As DirectSound
Public DsoundPri70 As DirectSoundBuffer
Public DsoundLis70 As DirectSound3DListener
Private Property Let Attemtstr(Str As String)
    Attemt = Str
    RaiseEvent Attemt4(Attemt)
End Property


'Direct sound Functions
Public Sub InitDsound70()
    On Local Error GoTo errout
    
    Attemtstr = "Creating Directsound"
    
    Set DSOUND70 = m_dx.DirectSoundCreate("")
    Attemtstr = "Setting DirectsoundCooperativeLevel"
    DSOUND70.SetCooperativeLevel m_hwnd, DSSCL_PRIORITY
    
    Attemtstr = "Creating primarySoundBuffer"
    Dim dsbd As DSBUFFERDESC
    Dim wfmt As WAVEFORMATEX
    dsbd.lFlags = DSBCAPS_PRIMARYBUFFER Or DSBCAPS_CTRL3D
    Set DsoundPri70 = DSOUND70.CreateSoundBuffer(dsbd, wfmt)
    
    Attemtstr = "Creating Directsoundlisner"
    Set DsoundLis70 = DsoundPri70.GetDirectSound3DListener()
    
    Exit Sub
errout:
    Err.Clear
    RaiseEvent Error4("Error in " + Attemt)
End Sub
Public Function Create2DsBuffromfile70(Sfile As String) As DirectSoundBuffer
    On Local Error GoTo errout
    
    Dim dsbd As DSBUFFERDESC
    Dim wfmt As WAVEFORMATEX
    
    Attemtstr = "Creating 2DSoundBufferFromfile " + Sfile
    dsbd.lFlags = DSBCAPS_CTRL3D Or DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME Or DSBCAPS_STATIC
    Set Create2DsBuffromfile70 = DSOUND70.CreateSoundBufferFromFile(Sfile, dsbd, wfmt)
    
    Exit Function
errout:
    Err.Clear
    RaiseEvent Error4("Error in " + Attemt)
End Function
Public Function Create3DSBUFfrom2Dbuf70(Buf As DirectSoundBuffer) As DirectSound3DBuffer
    On Local Error GoTo errout
    
    Attemtstr = "Creating 3DSound Buffer"
    Set Create3DSBUFfrom2Dbuf70 = Buf.GetDirectSound3DBuffer
    Exit Function
errout:
    Err.Clear
    RaiseEvent Error4("Error in " + Attemt)
End Function

'-============================================================
' StartWindowed
'-============================================================
Public Function StartWindowed() As Boolean
    Dim b As Boolean
                
    b = InitWindowed("", "IID_IDirect3DHALDevice")
    If b = True Then
        StartWindowed = True
        Exit Function
    End If
    
    b = InitWindowed("", "IID_IDirect3DRGBDevice")
    StartWindowed = b
        
End Function
'-============================================================
' InitWindowed
'-============================================================
Public Function InitWindowed(ddrawguid As String, d3dguid As String) As Boolean
    Dim b As Boolean
    Dim ddsd As DDSURFACEDESC2
    
    On Local Error GoTo errout
        
    m_binit = False
    
    Attemtstr = "make sure we have com out of fullscreen mode"
    If Not (m_dd Is Nothing) Then m_dd.RestoreDisplayMode
    If Not (m_dd Is Nothing) Then m_dd.SetCooperativeLevel 0, DDSCL_NORMAL

    Cleanup
    
    Attemtstr = "get rid of our current rm device.."
    Set m_rmDevice = Nothing
    Set m_rmViewport = Nothing
    
    m_strDDGuid = ddrawguid
    m_strD3DGuid = d3dguid
    
    If d3dguid = "" Then m_strD3DGuid = "IID_IDirect3DRGBDevice"
    If m_bUseSoftwareOnly = True Then m_strD3DGuid = "IID_IDirect3DRGBDevice"

    Attemtstr = "creating requested DirectDraw object from ddrawguid"
    Set m_dd = m_dx.DirectDraw4Create(m_strDDGuid)
    
    Attemtstr = "Setting The CooperativeLevel"
    m_dd.SetCooperativeLevel m_hwnd, DDSCL_NORMAL
    
    Attemtstr = "Creating screen surface from DirectDraw"
    ddsd.lFlags = DDSD_CAPS
    ddsd.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
    Set m_frontBuffer = m_dd.CreateSurface(ddsd)
    
    Attemtstr = "setting the clipper"
    Set m_ddClip = m_dd.CreateClipper(0)
    m_ddClip.SetHWnd m_hwnd
    m_frontBuffer.SetClipper m_ddClip
    
    b = ResizeWindowedDevice(m_strD3DGuid)
    If b = False Then GoTo errout
    
    SetDeviceDefaults
    
    m_binit = True
    m_bfullscreen = False
    InitWindowed = True
    Exit Function
    
errout:
    Cleanup
    RaiseEvent Error4("Error in " + Attemt)
End Function

'-============================================================
' ResizeWindowedDevice
'-============================================================
Private Function ResizeWindowedDevice(d3dg As String) As Boolean
    If m_dd Is Nothing Then Exit Function
    
    If m_bfullscreen Then Exit Function
    
    On Local Error GoTo errout
    
    
    Dim memflags As Long
    Dim r As RECT
    Dim ddsd As DDSURFACEDESC2
    
    'Get window extent
    Call m_dx.GetWindowRect(m_hwnd, r)
    ddsd.lWidth = r.right - r.left
    ddsd.lHeight = r.bottom - r.top
    
    Set m_rmViewport = Nothing
    Set m_rmDevice = Nothing
    Set m_backBuffer = Nothing
    
    
    'Take care of createFromWindowed shortcut
    If m_bCreateFromClipper Then
        
        Attemtstr = "Creating RM Device or Viewport for current window size"
        Set m_rmDevice = m_rm.CreateDeviceFromClipper(m_ddClip, d3dg, ddsd.lWidth, ddsd.lHeight)
        Set m_rmViewport = m_rm.CreateViewport(m_rmDevice, m_rmFrameCamera, 0, 0, ddsd.lWidth, ddsd.lHeight)
        
        ResizeWindowedDevice = True
        Exit Function
    
    End If
    
    
    If UCase(d3dg) = "IID_IDIRECT3DHALDEVICE" Then
        memflags = DDSCAPS_VIDEOMEMORY
    Else
        memflags = DDSCAPS_SYSTEMMEMORY
    End If

    
    'CreateBacksurface
    ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_3DDEVICE Or memflags
           
    Attemtstr = "creating backbuffer for current window size - try setting Use3DHardware=FALSE"
    Set m_backBuffer = m_dd.CreateSurface(ddsd)
    
    Attemtstr = "creating RM Device or Viewport for current window size"
    Set m_rmViewport = Nothing
    Set m_rmDevice = Nothing
    Set m_rmDevice = m_rm.CreateDeviceFromSurface(d3dg, m_dd, m_backBuffer, 0)
    Set m_rmViewport = m_rm.CreateViewport(m_rmDevice, m_rmFrameCamera, 0, 0, ddsd.lWidth, ddsd.lHeight)
    
        
    ResizeWindowedDevice = True
    Exit Function
    
errout:

    Err.Clear
    Set m_rmDevice = Nothing
    Set m_rmViewport = Nothing
    Set m_backBuffer = Nothing
    
    ResizeWindowedDevice = False
    m_binit = False
    RaiseEvent Error4("Error in " + Attemt)

End Function


'-============================================================
' InitFullScreen
'-============================================================
Public Function InitFullScreen(ddrawguid As String, d3dguid As String, w As Long, h As Long, bpp As Long, Optional TripleBuffering As Boolean) As Boolean
    
    On Local Error GoTo errout
    
    m_binit = False
    
    'get rid of our current rm device..
    Cleanup
    
    'make sure fs window is up
    
    DoEvents
    
    m_strDDGuid = ddrawguid
    If d3dguid = "" Then m_strD3DGuid = "IID_IDirect3DRGBDevice"
    
    'DirectDrawCreate
    Attemtstr = "Creating DirectDraw Object Create for given ddrawguid"
    Set m_dd = dx.DirectDraw4Create(m_strDDGuid)
    
    'Set cooperative level
    Attemtstr = "Setting CooperativeLevel for fullscreen operation"
    m_dd.SetCooperativeLevel m_hwnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE Or DDSCL_ALLOWMODEX

    'set the display mode
    If w <> 0 And h <> 0 And bpp <> 0 Then
        Attemtstr = "setting full screen display mode at requested w h and bpp"
        m_dd.SetDisplayMode w, h, bpp, 0, DDSDM_DEFAULT
    End If

    Dim ddsd As DDSURFACEDESC2
    If TripleBuffering = False Then
        'create Flipping Surfaces - one front and 1 back buffer
        ddsd.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
        ddsd.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_VIDEOMEMORY Or DDSCAPS_3DDEVICE
        ddsd.lBackBufferCount = 1
        Attemtstr = "Creating filipable surface for fullscreen operation"
        Set m_frontBuffer = m_dd.CreateSurface(ddsd)
    Else
        'create Flipping Surfaces - one front and 2 back buffer
        ddsd.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
        ddsd.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_VIDEOMEMORY Or DDSCAPS_3DDEVICE
        ddsd.lBackBufferCount = 2
        Attemtstr = "Creating filipable surface for fullscreen operation Using TripleBuffering"
        Set m_frontBuffer = m_dd.CreateSurface(ddsd)
    End If
    'Setup a clipper
    Attemtstr = "settingup the clipper"
    Set m_ddClip = m_dd.CreateClipper(0)
    m_ddClip.SetHWnd m_hwnd
    m_frontBuffer.SetClipper m_ddClip
            
    'Get backbuffer
    Dim caps As DDSCAPS2
    caps.lCaps = DDSCAPS_BACKBUFFER
    Attemtstr = "getting the fullscreen backbuffer"
    Set m_backBuffer = m_frontBuffer.GetAttachedSurface(caps)
    
    'get backbuffer description
    Dim ddsd2 As DDSURFACEDESC2
    Attemtstr = "getting the fullscreen backbuffer description"
    m_backBuffer.GetSurfaceDesc ddsd2
    
    
    'see if they turned hw off
    If m_bUseSoftwareOnly Then
        m_strD3DGuid = "IID_IDirect3DRGBDevice"
    Else
        m_strD3DGuid = d3dguid
    End If
    
    'create the rm device from surface
    Attemtstr = "Creating the Retained Mode device - try a smaller resolution or try setting  Use3DHardware=false"
    Set m_rmDevice = m_rm.CreateDeviceFromSurface(m_strD3DGuid, m_dd, m_backBuffer, D3DRMDEVICE_DEFAULT)
    Set m_rmViewport = m_rm.CreateViewport(m_rmDevice, m_rmFrameCamera, 0, 0, ddsd2.lWidth, ddsd2.lHeight)
    
    SetDeviceDefaults
    
    m_binit = True
    m_bfullscreen = True
    InitFullScreen = True
    Exit Function

errout:
    m_binit = False
    Cleanup
    RaiseEvent Error4("Error in " + Attemt)
End Function


'Run Time R/O access properties

'-============================================================
' Dx
'-============================================================
Public Function dx() As DirectX7
    Set dx = m_dx

End Function

'-============================================================
' DDraw
'-============================================================
Public Function DDraw() As DirectDraw4
    Set DDraw = m_dd
End Function

'-============================================================
' BackBuffer
'-============================================================
Public Function BackBuffer() As DirectDrawSurface4
    Set BackBuffer = m_backBuffer
End Function

'-============================================================
' D3drm
'-============================================================
Public Function D3DRM() As Direct3DRM3
    Set D3DRM = m_rm
End Function

'-============================================================
' Device
'-============================================================
Public Function Device() As Direct3DRMDevice3
    Set Device = m_rmDevice
End Function

'-============================================================
' Viewport
'-============================================================
Public Function Viewport() As Direct3DRMViewport2
    Set Viewport = m_rmViewport
End Function
 
'-============================================================
' DirLightFrame
'-============================================================
Public Function DirLightFrame() As Direct3DRMFrame3
    Set DirLightFrame = m_rmFrameDirLight
End Function
'-============================================================
Public Function SceneFrame() As Direct3DRMFrame3
    Set SceneFrame = m_rmFrameScene
End Function
 
'-============================================================
' CameraFrame
'-============================================================
Public Function CameraFrame() As Direct3DRMFrame3
    Set CameraFrame = m_rmFrameCamera
End Function
 
'-============================================================
' DirLight
'-============================================================
Public Function DirLight() As Direct3DRMLight
    Set DirLight = m_rmDirLight
End Function