CodeItBetter Programming Another VB Programming Blog

'Graphics - How to display 2D pictures
Option Explicit
 
'A reference to Directx8 is required.

Public DirectX As DirectX8
Public Direct3D As Direct3D8
Public DisplayMode As D3DDISPLAYMODE
Public Device As Direct3DDevice8
Public d3dx As D3DX8
 
Type TexturePool
    Texture As Direct3DTexture8
    Center As D3DVECTOR2
    Used As Boolean
End Type
Public Tex() As TexturePool
Dim Sprite As D3DXSprite
 
Type FontPool
    dX8Font As D3DXFont
    Used As Boolean
End Type
Public D3DFont() As FontPool
 
Public GlobalScaling As D3DVECTOR2
Dim NoScaling As D3DVECTOR2
 
Public Sub Initialize(ByVal nHWnd As Long)
' DirectX 8 installed ?
    On Error Resume Next
    Set DirectX = New DirectX8
    If DirectX Is Nothing Then
        MsgBox "DirectX 8 needed, sorry.", vbExclamation
        Exit Sub
    End If
 
    ' Initialize Direct3D
    Set Direct3D = DirectX.Direct3DCreate
 
    'Some more variables...
    Dim dmode As D3DDISPLAYMODE
    Dim D3DDM As D3DDISPLAYMODE
 
    Dim D3DCaps As D3DCAPS8
 
    Dim D3DPP As D3DPRESENT_PARAMETERS
 
    'Let's try it with hardware access
    Dim DevType As CONST_D3DDEVTYPE
    DevType = D3DDEVTYPE_HAL    'HAL->Hardware Access Layer

    'Let's get the caps for the default device
    Call Direct3D.GetDeviceCaps(D3DADAPTER_DEFAULT, DevType, D3DCaps)
 
    If Err.Number Then
        Err.Clear
        Debug.Print "HAL not available, trying REF"
        DevType = D3DDEVTYPE_REF
        Call Direct3D.GetDeviceCaps(D3DADAPTER_DEFAULT, DevType, D3DCaps)
        'Still error? Hell, what's wrong with this machine???

        If Err.Number Then
            MsgBox "error"
            Exit Sub
        End If
    End If
 
    'Grab some information about the current display mode.
    Call Direct3D.GetAdapterDisplayMode(D3DADAPTER_DEFAULT, D3DDM)
 
    'Now we'll go ahead and fill the D3DPRESENT_PARAMETERS type.
    With D3DPP
        .SwapEffect = D3DSWAPEFFECT_FLIP
        'Set the width and height to current resolution
        .BackBufferWidth = D3DDM.Width
        .BackBufferHeight = D3DDM.Height
 
        'Set the backbuffer format
        .BackBufferFormat = D3DDM.Format    'current format
    End With
 
    'Try to create the device now that we have everything set.
    Set Device = Direct3D.CreateDevice(D3DADAPTER_DEFAULT, DevType, nHWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, D3DPP)
 
    ' make Load texture possible
    Set d3dx = New D3DX8
 
    'Some render states
    Device.SetRenderState D3DRS_FILLMODE, D3DFILL_POINT
    Device.SetRenderState D3DRS_SHADEMODE, D3DSHADE_FLAT
    Device.SetRenderState D3DRS_LIGHTING, 0
    Device.SetRenderState D3DRS_ALPHABLENDENABLE, 0
 
    ' Create our essential sprite
    Set Sprite = d3dx.CreateSprite(Device)    'cool, eh? no messing around with vertices ;-)

    'Clear texture pool & font pool
    ReDim Tex(0)
    ReDim D3DFont(0)
    'Set standard scalings
    GlobalScaling.x = 1: GlobalScaling.y = 1
    NoScaling.x = 1: NoScaling.y = 1
 
    Debug.Print "DXGFX8 successfully initialized"
End Sub
 
Public Function LoadTextureIntoPool(ByVal nFilename As String, nColorKey As Long, Optional pWidth As Long = D3DX_DEFAULT, Optional pHeight As Long = D3DX_DEFAULT) As Long    'Returns handle of texture in texturepool
    On Error GoTo Err_Loading_Texture
 
    Dim nTex As Long
    For n = 0 To UBound(Tex)
        If Tex(n).Used = False Then
            nTex = n
            GoTo AddTex
        End If
    Next n
 
    ReDim Preserve Tex(0 To UBound(Tex) + 1)
    nTex = UBound(Tex)
 
AddTex:
    Set Tex(nTex).Texture = d3dx.CreateTextureFromFileEx(Device, nFilename, pWidth, pHeight, D3DX_DEFAULT, 0, D3DFMT_UNKNOWN, D3DPOOL_MANAGED, D3DX_FILTER_POINT, D3DX_FILTER_POINT, nColorKey, ByVal 0, ByVal 0)
 
    Dim texnfo As D3DSURFACE_DESC
    Tex(nTex).Texture.GetLevelDesc 0, texnfo
 
    Tex(nTex).Center.x = texnfo.Width / 2
    Tex(nTex).Center.y = texnfo.Height / 2
 
    LoadTextureIntoPool = nTex
    Tex(nTex).Used = True
    Exit Function
 
Err_Loading_Texture:
    LoadTextureIntoPool = -1
    Debug.Print "Error " & Err.Number & " in LoadTextureIntoPool, file: " & nFilename
End Function
 
Public Sub ClearPrepareFrame()
    Device.Clear 0, ByVal 0, D3DCLEAR_TARGET, vbBlack, 1, &HFF
    Device.BeginScene
    Sprite.Begin
End Sub
 
Public Sub DisplaySprite(TexNr As Long, Pos As D3DVECTOR2, Rotation As Single, ByVal naffectedbyScaling As Boolean)
    Static TempScaling As D3DVECTOR2, TempCenter As D3DVECTOR2
    If naffectedbyScaling = True Then
        TempScaling = GlobalScaling
        TempCenter.x = Tex(TexNr).Center.x * GlobalScaling.x
        TempCenter.y = Tex(TexNr).Center.y * GlobalScaling.y
    Else
        TempScaling = NoScaling
        TempCenter = Tex(TexNr).Center
    End If
    Sprite.Draw Tex(TexNr).Texture, ByVal 0, TempScaling, TempCenter, Rotation, Pos, -1   '&HFFFFFFFF
End Sub
 
Public Sub EndSceneDisplayFrame()
    Sprite.End
    Device.EndScene
    Device.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Public Sub Destroy()
    For I = 0 To UBound(Tex)
        Set Tex(I).Texture = Nothing
    Next I
    ReDim Tex(0)
 
    For I = 0 To UBound(D3DFont)
        Set D3DFont(I).dX8Font = Nothing
    Next I
    ReDim D3DFont(0)
 
    Set Sprite = Nothing
    Set Device = Nothing
    Set Direct3D = Nothing
    Set d3dx = Nothing
    Set DirectX = Nothing
 
    Debug.Print "DXGFX8 objects successfully destroyed"
End Sub
 
Public Function CreateFont(nFontName As String, nSize As Long, nBold As Boolean, nItalic As Boolean, nUnderlined As Boolean) As Long   'Returns handle of font in fontpool
    On Error GoTo Err_InCreateFont
 
    Dim nFont As Long
    For n = 0 To UBound(D3DFont)
        If D3DFont(n).Used = False Then
            nFont = n: GoTo AddFont
        End If
    Next n
    'We need a new font place
    ReDim Preserve D3DFont(0 To UBound(D3DFont) + 1)
 
    nFont = UBound(D3DFont)
 
AddFont:
    Dim m_vbFont As IFont
    Dim x As New StdFont
 
    x.Name = nFontName
    x.Bold = nBold
    x.Italic = nItalic
    x.Underline = nUnderlined
    x.Size = nSize
 
    Set m_vbFont = x
 
    Set D3DFont(nFont).dX8Font = d3dx.CreateFont(Device, m_vbFont.hFont)
 
    D3DFont(nFont).Used = True
 
    CreateFont = nFont    'Return font handle

    Debug.Print "Font " & nFontName & " created (handle " & nFont & ")" & Form1.Font.Name
    Exit Function
 
Err_InCreateFont:
    Debug.Print "Error " & Err.Number & " in CreateFont: " & nFontName
    CreateFont = -1
End Function
 
Sub D3DDrawText(ByVal strText As String, ByVal FontNr As Long, ByVal nColor As Long, fRect As RECT)
    On Error Resume Next
 
    D3DFont(FontNr).dX8Font.Begin
 
    d3dx.DrawText D3DFont(FontNr).dX8Font, nColor, strText, fRect, 0
 
    D3DFont(FontNr).dX8Font.End
End Sub
 
'How can I use this:
Private Sub Form_Load()
    Dim Position As D3DVECTOR2
    modDXGFX8.Initialize Me.hwnd
    Position.x = 10
    Position.y = 10
    pic = modDXGFX8.LoadTextureIntoPool("pic.bmp", nColorKey)
    Do Until Finish = True
        modDXGFX8.ClearPrepareFrame
        modDXGFX8.DisplaySprite pic, Position, 0, False
        modDXGFX8.EndSceneDisplayFrame
        DoEvents
    Loop
End Sub