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

'This structure describes a transformed and lit vertex.
Private Type typeTLVERTEX
    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
    
'Flexible vertex format the describes transformed and lit vertices.
Private Const g_cFVF = D3DFVF_XYZRHW Or D3DFVF_TEX1 Or D3DFVF_DIFFUSE Or D3DFVF_SPECULAR
    
'public the DirectX objects/structs the app uses.
Private m_oDX As DirectX8
Private m_oD3D As Direct3D8
Private m_oDev As Direct3DDevice8
Private m_oD3DX As New D3DX8
Private m_oD3Dpp As D3DPRESENT_PARAMETERS

Private m_oTextures As New Collection
Private m_oTextures_Alpha As New Collection

'Module level variable to store the caps of the device.
Private m_oD3DCaps As D3DCAPS8

'Module level variable to store the display mode.
Private m_oD3ddm As D3DDISPLAYMODE

Private WithEvents m_oPicture As PictureBox
Attribute m_oPicture.VB_VarHelpID = -1

Public Property Get PictureBoxBeingUsed() As Object
    Set PictureBoxBeingUsed = m_oPicture
End Property
Public Property Get GetLeft() As Long
    GetLeft = m_oPicture.Left
End Property
Public Property Get GetTop() As Long
    GetTop = m_oPicture.Top
End Property
Public Property Get GetWidth() As Long
    GetWidth = m_oPicture.Width
End Property
Public Property Get GetHeight() As Long
    GetHeight = m_oPicture.Height
End Property
Public Property Get GetScaleWidth() As Long
    GetScaleWidth = m_oPicture.ScaleWidth
End Property
Public Property Get GetScaleHeight() As Long
    GetScaleHeight = m_oPicture.ScaleHeight
End Property
Public Property Get GetScaleLeft() As Long
    GetScaleLeft = m_oPicture.ScaleLeft
End Property
Public Property Get GetScaleTop() As Long
    GetScaleTop = m_oPicture.ScaleTop
End Property
Public Property Get GetScaleMode() As Long
    GetScaleMode = m_oPicture.ScaleMode
End Property

Public Sub InitializeDirectX(picDevice As Object)

    Dim nRetVal As Long
    
    Set m_oPicture = picDevice
    nRetVal = InitD3D()
    If nRetVal Then
        Call Err.Raise(nRetVal, "FOTATools.clsFOTADirectX.InitializeDirectX", "Unknown error during initialization")
        Call Unload(Me)
    End If
    
End Sub

'This sub handles the rendering of the scene.
Public Sub BeginSceneRender(Optional nColorToClearTo As Long = &HFF)
            
    Dim HR As Long
    Dim nLeft As Long, nTop As Long
        
    'Call TestCooperativeLevel to see what state the device is in.
    HR = m_oDev.TestCooperativeLevel
    
    If HR = D3DERR_DEVICELOST Then
        'If the device is lost, exit and wait for it to come back.
        Exit Sub
    ElseIf HR = D3DERR_DEVICENOTRESET Then
        'The device became lost for some reason (probably an alt-tab) and now
        'Reset() needs to be called to try and get the device back.
        'If the device failed to be reset, exit the sub.
        If ResetDevice() Then Exit Sub
    End If
    
    'Make sure the app isn't minimized.
    'If Me.WindowState <> vbMinimized Then
        'The app is ready for rendering.
        'Clear the back buffer
        Call m_oDev.Clear(0, ByVal 0&, D3DCLEAR_TARGET, nColorToClearTo, 0, 0)
        'Begin the 3d scene
        Call m_oDev.BeginScene
        'Set the background texture on the device
        'Call dev.SetTexture(0, d3dtBackground)
        'Draw the 2 polygons that make up the background
        'Call dev.DrawPrimitiveUP(D3DPT_TRIANGLESTRIP, 2, m_MainVerts(0), Len(m_MainVerts(0)))
        'Call the sub that renders the sprites
        'Call RenderSprites(oGame, nLeft, nTop)
    'End If
End Sub
Public Sub SetTexture(sKey As String)

    'Set the background texture on the device
    Dim oTexture As clsFOTADirectX_Texture
    Dim d3dTexture As Direct3DTexture8
    Dim nIndex As Long

    On Error GoTo ItsAlphaBlended
        Set oTexture = m_oTextures(sKey)
    On Error GoTo 0
    
    'If alpha blending was turned on
    If m_oDev.GetRenderState(D3DRS_ALPHABLENDENABLE) Then
        'Turn it back off
        Call m_oDev.SetRenderState(D3DRS_ALPHABLENDENABLE, 0)
    End If
    
    Call m_oDev.SetTexture(0, oTexture.m_d3dtTexture)
    
    Exit Sub
ItsAlphaBlended:
    On Error GoTo 0
    
    'Make sure the device supports alpha blending
    If m_oD3DCaps.TextureCaps And D3DPTEXTURECAPS_ALPHA Then
        'It does, so turn alpha blending on
        Call m_oDev.SetRenderState(D3DRS_ALPHABLENDENABLE, 1)
    End If
    
    Set oTexture = m_oTextures_Alpha(sKey)
    Call m_oDev.SetTexture(0, oTexture.m_d3dtTexture)
    
End Sub
Public Function IsTextureLoaded(sKey As String)

    Dim oTexture As clsFOTADirectX_Texture
    Dim i As Long
    IsTextureLoaded = False

    For i = 1 To m_oTextures.Count
        If m_oTextures(i).m_sKey = sKey Then
            IsTextureLoaded = True
            Exit Function
        End If
    Next i
    
    For i = 1 To m_oTextures_Alpha.Count
        If m_oTextures_Alpha(i).m_sKey = sKey Then
            IsTextureLoaded = True
            Exit Function
        End If
    Next i
    
End Function

Public Property Get DX() As DirectX8
    Set DX = m_oDX
End Property

Public Property Get D3D() As Direct3D8
    Set D3D = m_oD3D
End Property

Public Property Get Dev() As Direct3DDevice8
    Set Dev = m_oDev
End Property

Public Property Get D3DX() As D3DX8
    Set D3DX = m_oD3DX
End Property

Public Property Get D3Dpp() As D3DPRESENT_PARAMETERS
    D3Dpp = m_oD3Dpp
End Property

Public Property Get Textures() As Collection
    Set Textures = m_oTextures
End Property

Public Property Get D3DCaps() As D3DCAPS8
    D3DCaps = m_oD3DCaps
End Property

Public Property Get D3ddm() As D3DDISPLAYMODE
    D3ddm = m_oD3ddm
End Property

Public Sub DrawTraingleStrip(oaVertices() As typeTLVERTEX)
    Call m_oDev.DrawPrimitiveUP(D3DPT_TRIANGLESTRIP, 2, oaVertices(0), Len(oaVertices(0)))
End Sub

Public Sub GetTriangleStrip(ByRef aReturnVertexArray() As typeTLVERTEX, _
                                 nX1 As Double, nY1 As Double, _
                                 nX2 As Double, nY2 As Double, _
                                 nX3 As Double, nY3 As Double, _
                                 nX4 As Double, nY4 As Double)

    Dim i As Long
    
    aReturnVertexArray(0).X = nX1
    aReturnVertexArray(0).Y = nY1
    aReturnVertexArray(1).X = nX2
    aReturnVertexArray(1).Y = nY2
    aReturnVertexArray(2).X = nX3
    aReturnVertexArray(2).Y = nY3
    aReturnVertexArray(3).X = nX4
    aReturnVertexArray(3).Y = nY4
    
    For i = 0 To 3
        aReturnVertexArray(i).rhw = 1
        aReturnVertexArray(i).color = &HFFFFFF
        aReturnVertexArray(i).tu = Fix(i / 2)
        aReturnVertexArray(i).tv = (i + 1) Mod 2
    Next i
    
End Sub
Public Sub GetSquareTriangleStrip(ByRef aReturnVertexArray() As typeTLVERTEX, _
                                 nLeft As Double, nTop As Double, _
                                 nWidth As Double, nHeight As Double)

    Dim i As Long
    
    aReturnVertexArray(0).X = nLeft
    aReturnVertexArray(0).Y = nTop + nHeight
    aReturnVertexArray(1).X = nLeft
    aReturnVertexArray(1).Y = nTop
    aReturnVertexArray(2).X = nLeft + nWidth
    aReturnVertexArray(2).Y = nTop + nHeight
    aReturnVertexArray(3).X = nLeft + nWidth
    aReturnVertexArray(3).Y = nTop
    
    For i = 0 To 3
        aReturnVertexArray(i).rhw = 1
        aReturnVertexArray(i).color = &HFFFFFF
        aReturnVertexArray(i).tu = Fix(i / 2)
        aReturnVertexArray(i).tv = (i + 1) Mod 2
    Next i
    
End Sub
Public Sub GetRotatedSquareTriangleStrip(ByRef aReturnVertexArray() As typeTLVERTEX, _
                                         nLeft As Double, nTop As Double, _
                                         nWidth As Double, nHeight As Double, _
                                         nAngleInDeg As Double)

    Dim i As Long
    Dim nX As Double, nY As Double
    Dim oFunc As New clsFunctions
    
    aReturnVertexArray(0).X = -(nWidth / 2)
    aReturnVertexArray(0).Y = (nHeight / 2)
    aReturnVertexArray(1).X = -(nWidth / 2)
    aReturnVertexArray(1).Y = -(nHeight / 2)
    aReturnVertexArray(2).X = (nWidth / 2)
    aReturnVertexArray(2).Y = (nHeight / 2)
    aReturnVertexArray(3).X = (nWidth / 2)
    aReturnVertexArray(3).Y = -(nHeight / 2)
    
    For i = 0 To 3
        Call oFunc.Rotate(nAngleInDeg, _
                    CDbl(aReturnVertexArray(i).X), CDbl(aReturnVertexArray(i).Y), _
                    nX, nY)
        aReturnVertexArray(i).X = nLeft + nX + (nHeight / 2)
        aReturnVertexArray(i).Y = nTop + nY + (nWidth / 2)
    
        aReturnVertexArray(i).rhw = 1
        aReturnVertexArray(i).color = &HFFFFFF
        aReturnVertexArray(i).tu = Fix(i / 2)
        aReturnVertexArray(i).tv = (i + 1) Mod 2
    Next i
    
End Sub

Public Sub EndSceneRender()
    'End the scene
    Call m_oDev.EndScene
    'Draw the graphics to the front buffer.
    Call m_oDev.Present(ByVal 0&, ByVal 0&, 0, ByVal 0&)
End Sub
' This function creates the following objects: DirectX8, Direct3D8,
' Direc3DDevice8.
' Parameters:
' [IN]
'       hwnd:       Handle to a window that will be used as the render target
'       bWindowed:  Optional boolean argument that initializes either full screen
'                   or windowed. Default is windowed.
' [OUT]
'       dx:         Pass in an uninitialized DirectX8 object.
'       d3d:        Pass in an uninitialized Direct3D8 object.
'       dev:        Pass in an uninitialized Direct3DDevice8 object.
' Return value:
'     If an error occurs, it returns the Direct3D error number. In the
'     case that no fullscreen format was found, it returns D3DERR_INVALIDDEVICE.
Private Function InitD3D() As Long

    Dim devtype As CONST_D3DDEVTYPE
    Dim i As Long, lCount As Long, lErrNum As Long, format As Long
    Dim bFoundMode As Boolean

    'Turn off error checking. The app will check for errors and handle them.
    'On Local Error Resume Next

    'Initiazlize the DirectX8 object
    Set m_oDX = New DirectX8

    'Check to make sure that the dx object was created successfully.
    If Err.Number Then
        'There were problems creating the dx object. Return the error number.
        InitD3D = Err.Number
        Exit Function
    End If

    'Create the Direct3D object
    Set m_oD3D = m_oDX.Direct3DCreate

    'Check to make sure that the d3d object was created successfully.
    If Err.Number Then
        'There were problems creating the d3d object. Return the error number,
        InitD3D = Err.Number
        Exit Function
    End If

    'We'll start by attempting to create a HAL device. This variable
    'will hold the final type of device that we create after we check
    'some capabilities.
    devtype = D3DDEVTYPE_HAL

    'Get the capabilities of the Direct3D device that we specify. In this case,
    'we'll be using the adapter default (the primiary card on the system).
    Call m_oD3D.GetDeviceCaps(D3DADAPTER_DEFAULT, devtype, m_oD3DCaps)

    'Check for errors. If there is an error, the card more than likely doesn't support at least DX7,
    'so get the caps of the reference device instead.
    If Err.Number Then
        Err.Clear
        devtype = D3DDEVTYPE_REF
        Call m_oD3D.GetDeviceCaps(D3DADAPTER_DEFAULT, devtype, m_oD3DCaps)

        'If there is *still* an error, then the driver has problems. We'll
        'have to exit at this point, because there isn't anything else we can do.
        If Err.Number Then
            InitD3D = D3DERR_NOTAVAILABLE
            Exit Function
        End If
    End If

    'Grab some information about the current display mode.
    Call m_oD3D.GetAdapterDisplayMode(D3DADAPTER_DEFAULT, m_oD3ddm)

    'Now we'll go ahead and fill the D3DPRESENT_PARAMETERS type.
    With m_oD3Dpp
        'Make sure that the adapter is in a color bit-depth greater than 8 bits per pixel.
        If m_oD3ddm.format = D3DFMT_P8 Or m_oD3ddm.format = D3DFMT_A8P8 Then
            'Device is running in some variation of an 8 bit format
            Call Err.Raise(D3DERR_INVALIDDEVICE, "FOTATools.clsFOTADirectX.InitD3d", "For this sample to run, the primary display needs to be in 16 bit or higher color depth.")
            Exit Function
        Else
            'Device is greater than 8 bit. Set the format variable to the current display format.
            format = m_oD3ddm.format
        End If

        'For windowed mode, we just discard any information instead of flipping it.
        .SwapEffect = D3DSWAPEFFECT_DISCARD
        'Set windowed mode to true.
        .Windowed = 1
        'Set the backbuffer format
        .BackBufferFormat = format
    End With

    'Try to create the device now that we have everything set.
    Set m_oDev = m_oD3D.CreateDevice(D3DADAPTER_DEFAULT, devtype, m_oPicture.hwnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, m_oD3Dpp)

    'If the creation above failed, try to create a REF device instead.
    If Err.Number Then
        Call Err.Clear
        Set m_oDev = m_oD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_REF, m_oPicture.hwnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, m_oD3Dpp)

        If Err.Number Then
            'The app still hit an error. Both HAL and REF devices weren't created. The app will have to exit at this point.
            InitD3D = Err.Number
            Exit Function
        End If
    End If

    If InitDevice() Then
        Call Err.Raise(D3DERR_INVALIDDEVICE, "FOTATools.clsFOTADirectX.InitD3d", "Unable to initialize the device")
        Call Unload(Me)
    End If

End Function
' This function initializes the device with some renderstates, and also
' sets up the viewport, camera, and world.
' Parameters:
' [IN]
'       dev:    An existing Direct3DDevice8 object
'       m_od3dpp:  A filled D3DPRESENT_PARAMETERS type
'       hwnd:   Handle to the target window
' Return value:
'     If an error occurs, it returns D3DERR_INVALIDCALL.
Private Function InitDevice() As Long

    With m_oDev
        'Set the vertex shader to an g_cFVF that contains texture coords,
        'and transformed and lit vertex coords.

        Call .SetVertexShader(g_cFVF)
        'Turn off lighting
        Call .SetRenderState(D3DRS_LIGHTING, 0)
        'Set the render state that uses the alpha component as the source for blending.
        Call .SetRenderState(D3DRS_SRCBLEND, D3DBLEND_SRCALPHA)
        'Set the render state that uses the inverse alpha component as the destination blend.
        Call .SetRenderState(D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA)
    End With
        
    If Err.Number Then InitDevice = D3DERR_INVALIDCALL
    
End Function

Public Sub LoadTextureWithAlphaBlending(sFileName As String, Optional nAlphaColor As Long = &HFF000000, Optional sKey As String = "")
    
    Dim oTexture As New clsFOTADirectX_Texture
    
    'Find a key value
    oTexture.m_sKey = sKey
    If Len(sKey) = 0 Then
        oTexture.m_sKey = sFileName
    End If
    
    'Load the Sprite texture. We need to get alpha information embedded into this
    'surface, so we'll call the more complex CreateTextureFromFileEx() method instead.
    'The main thing we need to do is just let it know we want to use black as the
    'alpha channel. We do this by passing &HFF000000 to the method, and it fills in
    'the high order byte of any pixel that contains black with full alpha so that it
    'becomes transparent when rendered with alpha blending enabled.
    Set oTexture.m_d3dtTexture = D3DX.CreateTextureFromFileEx(m_oDev, sFileName, _
                            D3DX_DEFAULT, D3DX_DEFAULT, D3DX_DEFAULT, 0, _
                            D3DFMT_UNKNOWN, D3DPOOL_MANAGED, D3DX_FILTER_POINT, D3DX_FILTER_POINT, _
                            nAlphaColor, ByVal 0, ByVal 0)

    Call m_oTextures_Alpha.Add(oTexture, oTexture.m_sKey)

End Sub
Public Sub LoadTexture(sFileName As String, Optional sKey As String = "")
            
    Dim oTexture As New clsFOTADirectX_Texture
    
    'Find a key value
    oTexture.m_sKey = sKey
    If Len(sKey) = 0 Then
        oTexture.m_sKey = sFileName
    End If
    
    'Check to make sure the media was found
    If Dir(sFileName) = vbNullString Then
        Call Err.Raise(-1, "FOTATools.clsFOTADirectX.LoadTexture", "Unable to locate sample media <" & sFileName & ">")
        Unload Me
    End If
    
    'Load the background texture
    Set oTexture.m_d3dtTexture = m_oD3DX.CreateTextureFromFile(m_oDev, sFileName)
        
    Call m_oTextures.Add(oTexture, oTexture.m_sKey)
    
End Sub
' This sub switches the current display mode between windowed/fullscreen.
' If it runs into an error, it just exits, leaving the display mode in its current state.
Public Sub SwitchWindowMode()
    
    Dim d3dppEmpty As D3DPRESENT_PARAMETERS
    Dim format As Long
    Dim lErrNum As Long
    
    'Grab a valid format for this device. If a format
    'for the requested resolution wasn't found, exit the sub.
    If FindMode(Screen.Width, Screen.Height, format) <> 0 Then Exit Sub
            
    'Store the current window mode format
    Call m_oD3D.GetAdapterDisplayMode(D3DADAPTER_DEFAULT, m_oD3ddm)
    
    'Set the present parameters for running full screen
    m_oD3Dpp = d3dppEmpty
    
    With m_oD3Dpp
        .SwapEffect = D3DSWAPEFFECT_FLIP
        .BackBufferFormat = format
'Chris
        .BackBufferWidth = 1000  'g_cWORLDWIDTH
        .BackBufferHeight = 1000 'g_cWORLDHEIGHT
        .Windowed = 0
    End With
    
    'Reset the device to the new mode
    lErrNum = ResetDevice
    
    'If there is an error resetting the device, just exit the sub.
    If lErrNum Then
        'Store the client dimensions
        Exit Sub
    End If
    
End Sub
' This subroutine is called whenever the form is resized. It resets the device to the new size, and re-inits the device.
Public Sub ResizeWindow()
    'Reset the device to the new mode
    Call ResetDevice
End Sub
' This subroutine is called whenever the app needs to be resized, or the device has been lost.
Private Function ResetDevice() As Long
    
    Call m_oDev.Reset(m_oD3Dpp)

    If Err.Number Then
        ResetDevice = Err.Number
        Exit Function
    End If
    
    'Now get the device ready again
    Call InitDevice

End Function
' This function returns a valid back buffer format for the width and height passed in.
' Parameters:
' [IN]
'      w is the width of the mode being sought
'      h is the height of the mode being sought
' [OUT]
'     fmt will be filled in with a valid CONST_D3DFORMAT
' Return value:
'     If a valid format was not found, D3DERR_INVALIDDEVICE is returned.
'     If an error occurs, it returns D3DERR_INVALIDCALL.
Private Function FindMode(ByVal w As Long, ByVal h As Long, fmt As Long) As Long
    
    Dim i  As Long, lCount As Long
    Dim D3ddm As D3DDISPLAYMODE
    Dim bFoundMode As Boolean
    
    i = 0
    
    'Get the number of adapter modes this adapter supports.
    lCount = m_oD3D.GetAdapterModeCount(D3DADAPTER_DEFAULT) - 1
    
    'If we encounter an error, return an error code and exit the function.
    If Err.Number Then
        FindMode = D3DERR_INVALIDCALL
        Exit Function
    End If
    
    'Next, loop through all the display modes until we find one
    'that matches the parameters passed in.
    For i = 0 To lCount
        
        Call m_oD3D.EnumAdapterModes(D3DADAPTER_DEFAULT, i, D3ddm)
        
        'Again, catch any unexpected errors.
        If Err.Number Then
            FindMode = Err.Number
            Exit Function
        End If
        
        'Check to see if this mode matches what is being sought.
        If D3ddm.Width = w And D3ddm.Height = h Then
            'Now see if this mode is either a 32bpp or 16bpp mode
            If D3ddm.format = D3DFMT_R8G8B8 Or D3ddm.format = D3DFMT_R5G6B5 Then
                'We've found a suitable display. Set the flag
                'to reflect this, and exit. No need to look further.
                bFoundMode = True
                'Set the fmt to the format that was found.
                fmt = D3ddm.format
                Exit For
            End If
        End If
    Next
        
    If bFoundMode Then
        'Everything checked out OK
        Exit Function
    Else
        'Return an error
        FindMode = D3DERR_INVALIDDEVICE
    End If
    
End Function
'Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'    If (Shift And vbAltMask) And KeyCode = vbKeyReturn Then
'        'User wants to switch from fullscreen/windowed mode
'        Call SwitchWindowMode
'    End If
'End Sub
'Private Sub Form_Resize()
'
'    'Call the subroutine that resizes the backbuffer on the device.
'    'Make sure the device exists, and the app is windowed.
'    'Make sure the app isn't minimized.
'    If Not dev Is Nothing And Me.WindowState <> vbMinimized Then
'        Call ResizeWindow
'    End If
'
'End Sub
Private Sub m_oPicture_KeyDown(KeyCode As Integer, Shift As Integer)
    If (Shift And vbAltMask) And KeyCode = vbKeyReturn Then
        'User wants to switch from fullscreen/windowed mode
        Call SwitchWindowMode
    End If
End Sub
