DirextX编程

开发平台：
Visual Basic

DX8公共模块.bas：源码内容
							Attribute VB_Name = "DX公共模块"
Option Explicit
' Download by http://www.codefans.net
'/////////////////////////定义公共D3D变量/////////////////////////////
Public DX8 As DirectX8
Public D3DX As D3DX8
Public D3D8 As Direct3D8
Public D3DDevice As Direct3DDevice8
Public MainSprite As D3DXSprite
Public Mode As D3DDISPLAYMODE
Public DPP As D3DPRESENT_PARAMETERS
Public D3DFontDesc As IFont
Public Fnt As New StdFont
Public D3DFont As D3DXFont
Public D3DFont1 As D3DXFont
Public D3DFont2 As D3DXFont
'///////////  定义声音变量
Public DS As DirectSound8
Public DMP As DirectMusicPerformance8
Public DML As DirectMusicLoader8
Public DSBDESC As DSBUFFERDESC
Public Type TLVERTEX
    X As Single
    Y As Single
    Z As Single
    rhw As Single
    color As Long
    specular As Long
    tu As Single
    tv As Single
End Type
Public Const FVF = D3DFVF_XYZRHW Or D3DFVF_TEX1 Or D3DFVF_DIFFUSE Or D3DFVF_SPECULAR
Public mRECT As RECT
Public AddResErrorCount As Integer
'///////////////////////定义公共D3D变量结束/////////////////////////////
'////////////////////////初始化D3D/////////////////////////////////////
Public Sub InitD3D(窗口句柄 As Long, Optional 全屏 As Boolean = False, Optional 宽度 As Integer = 800, Optional 高度 As Integer = 600)
    Set DX8 = New DirectX8
    Set D3DX = New D3DX8
    Set D3D8 = DX8.Direct3DCreate
    If 全屏 = False Then
        D3D8.GetAdapterDisplayMode 0, Mode
        DPP.BackBufferCount = 1
        DPP.BackBufferFormat = Mode.Format
        DPP.SwapEffect = D3DSWAPEFFECT_FLIP
        DPP.AutoDepthStencilFormat = D3DFMT_D16
        DPP.EnableAutoDepthStencil = 1
        DPP.BackBufferWidth = 宽度
        DPP.BackBufferHeight = 高度
        DPP.Windowed = 1
    ElseIf 全屏 = True Then
        DPP.SwapEffect = D3DSWAPEFFECT_DISCARD
        DPP.BackBufferFormat = D3DFMT_R5G6B5
        DPP.BackBufferCount = 1
        DPP.BackBufferWidth = 宽度
        DPP.BackBufferHeight = 高度
            
        DPP.AutoDepthStencilFormat = D3DFMT_D16
        DPP.EnableAutoDepthStencil = 1
        DPP.hDeviceWindow = 窗口句柄
    End If
    Set D3DDevice = D3D8.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, 窗口句柄, D3DCREATE_SOFTWARE_VERTEXPROCESSING, DPP)
    If D3DDevice Is Nothing Then
        MsgBox "D3D初始化失败!", vbSystemModal, "初始化错误"
        End
    End If
    
    Set MainSprite = D3DX.CreateSprite(D3DDevice)
    ResetStates
    With D3DDevice
        
        .SetRenderState D3DRS_POINTSPRITE_ENABLE, 1 'True
        .SetRenderState D3DRS_POINTSCALE_ENABLE, 0 'True
        .SetRenderState D3DRS_POINTSIZE, FtoDW(15)
'        .SetRenderState D3DRS_POINTSIZE_MIN, lngFloat0
'        .SetRenderState D3DRS_POINTSCALE_A, lngFloat0
'        .SetRenderState D3DRS_POINTSCALE_B, lngFloat0
'        .SetRenderState D3DRS_POINTSCALE_C, lngFloat1
        .SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA
        .SetRenderState D3DRS_DESTBLEND, D3DBLEND_ONE
        .SetRenderState D3DRS_ALPHABLENDENABLE, 1
        .SetVertexShader FVF
    End With
    
    Fnt.Name = "宋体"
    Fnt.Size = 9
    Set D3DFontDesc = Fnt
    Set D3DFont = D3DX.CreateFont(D3DDevice, D3DFontDesc.hFont)
    
    Fnt.Name = "宋体"
    Fnt.Size = 9
    Fnt.Underline = True
    Set D3DFontDesc = Fnt
    Set D3DFont1 = D3DX.CreateFont(D3DDevice, D3DFontDesc.hFont)
    
    Fnt.Name = "宋体"
    Fnt.Size = 9
    Fnt.Underline = False
    Set D3DFontDesc = Fnt
    Set D3DFont2 = D3DX.CreateFont(D3DDevice, D3DFontDesc.hFont)
    
    
    InitD3DSound
End Sub
Public Sub ResetStates()
    With D3DDevice
        Call .SetVertexShader(FVF)
        Call .SetRenderState(D3DRS_LIGHTING, False)
        Call .SetRenderState(D3DRS_SRCBLEND, D3DBLEND_SRCALPHA)
        Call .SetRenderState(D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA)
        Call .SetRenderState(D3DRS_ZENABLE, False)
        Call .SetRenderState(D3DRS_ZWRITEENABLE, False)
        Call .SetRenderState(D3DRS_CULLMODE, D3DCULL_NONE)
        Call .SetRenderState(D3DRS_SHADEMODE, D3DSHADE_FLAT)
        Call .SetRenderState(D3DRS_FILLMODE, CONST_D3DFILLMODE.D3DFILL_SOLID)
        .SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
        .SetTextureStageState 0, D3DTSS_COLORARG2, D3DTA_DIFFUSE
        .SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_MODULATE
        .SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE
        Call .SetTextureStageState(0, D3DTSS_MINFILTER, D3DTEXF_LINEAR)
        Call .SetTextureStageState(0, D3DTSS_MAGFILTER, D3DTEXF_LINEAR)
    End With
End Sub
'////////////// 定义声音模块  /////////////////////////////////
Sub InitD3DSound()
    Set DS = DX8.DirectSoundCreate("")
    DS.SetCooperativeLevel FrmMain.hWnd, DSSCL_NORMAL
    DSBDESC.lFlags = DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME
End Sub
'///////////////////////// 定义创建贴图函数 ///////////////////////////////
Public Sub CreateTexture(mTexInfo As TexInfo, FileName As String, Optional Width As Long = -1, Optional Height As Long = -1, Optional ColorKey As OLE_COLOR = &HFF000000)
    Dim FileData() As Byte, mLen As Long
On Error GoTo eLabel:
    
CrTex:
    Close #1
    If mTexInfo.Enabled = True Then Exit Sub
    Open FileName For Binary As #1
        Get #1, mTexInfo.StartPos + 1, mTexInfo.Wid
        Get #1, , mTexInfo.Hei
        Get #1, , mTexInfo.PosX
        Get #1, , mTexInfo.PosY
        mLen = mTexInfo.EndPos - mTexInfo.StartPos
        ReDim FileData(mLen - 1)
        Get #1, mTexInfo.StartPos + 13, FileData()
    Close #1
    Open App.Path & "mir.dat" For Binary As #1
        Put #1, , BH
        BI.biWidth = mTexInfo.Wid
        BI.biHeight = mTexInfo.Hei
        BI.biSizeImage = BI.biWidth * BI.biHeight
        Put #1, , BI
        Put #1, , BiRGB()
        Put #1, , FileData()
    Close #1
    
    
    Set mTexInfo.Tex = D3DX.CreateTextureFromFileEx(D3DDevice, App.Path & "mir.dat", Width, Height, _
                                              D3DX_DEFAULT, D3DUSAGE_RENDERTARGET, D3DFMT_UNKNOWN, D3DPOOL_DEFAULT, _
                                              D3DX_FILTER_NONE, D3DX_FILTER_NONE, ColorKey, ByVal 0, _
                                                ByVal 0)
    If mTexInfo.Tex Is Nothing Then
        MsgBox "无法生成材质" & FileName
    End If
    AddResErrorCount = 0
    Exit Sub
eLabel:
'    If MsgBox("加载材质" & FileName & "失败", vbYesNo Or vbDefaultButton2, "错误") = vbYes Then
'        Unload FrmMain
'        End
'    End If
    
    AddResErrorCount = AddResErrorCount + 1
    mTexInfo.Enabled = True
    If AddResErrorCount > 2 Then
        MsgBox "加载游戏资源错误,游戏将中止!,请尝试重新进入游戏!"
        ReleaseMemory
        ClearDx
        End
    End If
    ReleaseMemory
    GoTo CrTex
End Sub
Public Sub CreateTexture1(Texture As Direct3DTexture8, FileName As String, Optional Width As Long = -1, Optional Height As Long = -1, Optional ColorKey As OLE_COLOR = &HFF000000)
    
On Error GoTo eLabel:
CrTex:
    Set Texture = D3DX.CreateTextureFromFileEx(D3DDevice, FileName, Width, Height, _
                                              D3DX_DEFAULT, D3DUSAGE_RENDERTARGET, D3DFMT_UNKNOWN, D3DPOOL_DEFAULT, _
                                              D3DX_FILTER_NONE, D3DX_FILTER_NONE, ColorKey, ByVal 0, _
                                                ByVal 0)
    If Texture Is Nothing Then
        MsgBox "无法生成材质" & FileName
    End If
    AddResErrorCount = 0
    Exit Sub
eLabel:
'    If MsgBox("加载材质" & FileName & "失败", vbYesNo Or vbDefaultButton2, "错误") = vbYes Then
'        Unload FrmMain
'        End
'    End If
    
    AddResErrorCount = AddResErrorCount + 1
    If AddResErrorCount > 2 Then
        MsgBox "加载游戏资源错误,游戏将中止!,请尝试重新进入游戏!"
        ReleaseMemory
        ClearDx
        End
    End If
    ReleaseMemory
    GoTo CrTex
End Sub
'//////////  释放游戏资源
Public Sub ReleaseMemory()
    Dim i As Long, j As Long
    For i = 0 To UBound(HumTex)
        Set HumTex(i).Tex = Nothing
    Next
    
    For i = 0 To UBound(PrguseTex)
        Set PrguseTex(i).Tex = Nothing
    Next
    
    
    For i = 0 To UBound(Prguse2Tex)
        Set Prguse2Tex(i).Tex = Nothing
    Next
    
    For i = 0 To UBound(Prguse3Tex)
        Set Prguse3Tex(i).Tex = Nothing
    Next
    
    For i = 0 To UBound(WeaponTex)
        Set WeaponTex(i).Tex = Nothing
    Next
    
    For i = 0 To UBound(NpcTex)
        Set NpcTex(i).Tex = Nothing
    Next
    
'    For i = 1 To UBound(MagicPic)
'        For j = 0 To UBound(MagicPic(i).MagicTex)
'            Set MagicPic(i).MagicTex(j).Tex = Nothing
'        Next
'    Next
    
    For i = 0 To UBound(ItemsTex)
        Set ItemsTex(i).Tex = Nothing
    Next
    
    For i = 0 To UBound(StateItemTex)
        Set StateItemTex(i).Tex = Nothing
    Next
    
    For i = 1 To UBound(MonPic)
        For j = 0 To UBound(MonPic(i).MonTex)
            Set MonPic(i).MonTex(j).Tex = Nothing
        Next
    Next
End Sub
Public Function CreateVertex(X As Single, Y As Single, Z As Single, rhw As Single, color As Long, _
                                               specular As Long, tu As Single, tv As Single) As TLVERTEX
    CreateVertex.X = X
    CreateVertex.Y = Y
    CreateVertex.Z = Z
    CreateVertex.rhw = rhw
    CreateVertex.color = color
    CreateVertex.specular = specular
    CreateVertex.tu = tu
    CreateVertex.tv = tv
End Function
Public Sub DrawAlphaTex(Texture As Direct3DTexture8, X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Optional nColor As Long = -1)
    D3DDevice.SetTexture 0, Texture
    Dim Ver(3) As TLVERTEX
    Ver(0) = CreateVertex(X1, Y1, 0, 0, nColor, 0, 0, 0)
    Ver(1) = CreateVertex(X2, Y1, 0, 0, nColor, 0, 1, 0)
    Ver(2) = CreateVertex(X1, Y2, 0, 0, nColor, 0, 0, 1)
    Ver(3) = CreateVertex(X2, Y2, 0, 0, nColor, 0, 1, 1)
    D3DDevice.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, Ver(0), Len(Ver(0))
    
End Sub
Public Function FtoDW(f As Single) As Long
    Dim buf As D3DXBuffer
    Dim l As Long
    Set buf = D3DX.CreateBuffer(4)
    D3DX.BufferSetData buf, 0, 4, 1, f
    D3DX.BufferGetData buf, 0, 4, 1, l
    FtoDW = l
End Function
Public Function Draw(Texture As Direct3DTexture8, X As Long, Y As Long, RC As RECT, _
               Optional ScX1 As Single = 1, Optional ScY1 As Single = 1, _
               Optional Rot1 As Single = 0, Optional cColor As OLE_COLOR = &HFFFFFFFF)
On Error GoTo ER
    
    
    Dim rt As D3DVECTOR2
    Dim sc As D3DVECTOR2
    Dim tl As D3DVECTOR2
    If Texture Is Nothing Then GoTo ER
    
    sc.X = ScX1: sc.Y = ScY1
    tl.X = X: tl.Y = Y
    rt.X = RC.Right / 2
    rt.Y = RC.bottom / 2
    Dim mmmRECT As RECT
    mmmRECT.Left = RC.Left
    mmmRECT.Top = RC.Top
    mmmRECT.Right = RC.Right
    mmmRECT.bottom = RC.bottom
    
    MainSprite.Draw Texture, RC, sc, rt, Rot1, tl, cColor
ER:
    
   
End Function
Public Sub ClearDx()
    Set MainSprite = Nothing
    Set D3DDevice = Nothing
    Set D3D8 = Nothing
    Set D3DX = Nothing
    Set DX8 = Nothing
End Sub

						