VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cS2D"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Caps As D3DCAPS8
Private DisplayMode As D3DDISPLAYMODE
Private PresentParameters As D3DPRESENT_PARAMETERS

Private SourceRect As RECT

Private Lights() As D3DLIGHT8
Public LightCount As Integer

Private Fonts() As D3DXFont
Public FontCount As Integer
Private FontRect As RECT

Private Type MeshObject
    Mesh As D3DXMesh
    MeshMaterials() As D3DMATERIAL8
    MeshTextures() As Direct3DTexture8
    MaterialCount As Long
    FileName As String
End Type

Private Meshes() As MeshObject
Public MeshCount As Integer
Public CurrentMesh As Integer

Public Sub EnumerateAdapters()

    Dim CurrentAdapters As Integer
    Dim TextBufferCount As Integer
    Dim TextBuffer As String
    Dim AdapterInfo As D3DADAPTER_IDENTIFIER8
    
    AdapterCount = D3D.GetAdapterCount
    
    For CurrentAdapters = 0 To AdapterCount - 1
        
        D3D.GetAdapterIdentifier CurrentAdapters, 0, AdapterInfo
        TextBuffer = ""
        
        For TextBufferCount = 0 To 511
            TextBuffer = TextBuffer & Chr$(AdapterInfo.Description(TextBufferCount))
        Next TextBufferCount
        
        TextBuffer = Replace(TextBuffer, Chr$(0), "")
        S2DLog.Add "Enumerated D3D Adapter: " & TextBuffer
    Next CurrentAdapters

End Sub

Public Sub EnumerateDevices(ByVal Adapter As Long)
    
    Dim Caps As D3DCAPS8

    On Local Error Resume Next
    D3D.GetDeviceCaps Adapter, D3DDEVTYPE_HAL, Caps
    
    If Err.Number = D3DERR_NOTAVAILABLE Then
        S2DLog.Add "Hardware Acceleration not available"
        HardwareAcceleration = False
    Else
        S2DLog.Add "Hardware Acceleration available"
        HardwareAcceleration = True
    End If

End Sub

Public Function EnumerateDisplayMode(ByVal Renderer As Long, ByVal Device As Long, ByVal intWidth As Integer, ByVal intHeight As Integer, ByVal Depth As Integer, Windowed As Long) As Boolean
                                     
    Dim CurrentModes As Integer
    Dim ModeTemp As D3DDISPLAYMODE

    ModeCount = D3D.GetAdapterModeCount(Device)
    For CurrentModes = 0 To ModeCount - CurrentModes
        Call D3D.EnumAdapterModes(Device, CurrentModes, ModeTemp)
        If ModeTemp.Format = D3DFMT_R8G8B8 Or ModeTemp.Format = D3DFMT_X8R8G8B8 Or ModeTemp.Format = D3DFMT_A8R8G8B8 Then
            If D3D.CheckDeviceType(Device, Renderer, ModeTemp.Format, ModeTemp.Format, Windowed) >= 0 Then
                S2DLog.Add "Adapter supports " & ModeTemp.Width & "*" & ModeTemp.Height & "*" & "32Bit"
                If ModeTemp.Width = intWidth Then
                    If ModeTemp.Height = intHeight Then
                        If Depth = 32 Then
                            EnumerateDisplayMode = True
                            Exit Function
                        End If
                    End If
                End If
            End If
         Else
            If D3D.CheckDeviceType(Device, Renderer, ModeTemp.Format, ModeTemp.Format, Windowed) >= 0 Then
                S2DLog.Add "Adapter supports " & ModeTemp.Width & "*" & ModeTemp.Height & "*" & "16Bit"
                If ModeTemp.Width = intWidth Then
                    If ModeTemp.Height = intHeight Then
                        If Depth = 16 Then
                            EnumerateDisplayMode = True
                            Exit Function
                        End If
                    End If
                End If
            End If
        End If
    Next CurrentModes

End Function

Public Sub EnumerateHardware(ByVal Renderer As Long, _
                             ByVal Device As Long)

    Dim Caps As D3DCAPS8

    D3D.GetDeviceCaps Device, Renderer, Caps
    MaximumTextureWidth = Caps.MaxTextureWidth
    MaximumTextureHeight = Caps.MaxTextureHeight
    MaximumPrimitives = Caps.MaxPrimitiveCount
    S2DLog.Add "Max. Texture size: " & Caps.MaxTextureWidth & "*" & Caps.MaxTextureHeight
    S2DLog.Add "Max. Primitive Count: " & Caps.MaxPrimitiveCount
    MaximumActiveLights = Caps.MaxActiveLights
    S2DLog.Add "Max. Active Lights: " & Caps.MaxActiveLights
    
    If Not Caps.VertexProcessingCaps = 0 Then
        HardwareVertexProcessing = True
    End If
    
    If Caps.TextureCaps And D3DPTEXTURECAPS_SQUAREONLY Then
        SquareTextureLimitation = True
        S2DLog.Add "Adapter has Square Texture limitation"
    Else
        S2DLog.Add "Adapter has NO Square Texture limitation"
    End If
    
    If Caps.Caps2 And D3DCAPS2_CANRENDERWINDOWED Then
        SupportsWindowedMode = True
        S2DLog.Add "Adapter supports windowed mode"
    Else
        S2DLog.Add "Adapter DOES NOT support windowed mode"
    End If

End Sub

Public Function Initialize(hwnd As Long, Optional EnableLight As Boolean = True)
     
    ScreenWidth = Screen.Width / Screen.TwipsPerPixelX
    ScreenHeight = Screen.Height / Screen.TwipsPerPixelY
    BackBufferWidth = ScreenWidth
    BackBufferHeight = ScreenHeight
    ScreenShiftX = ScreenWidth / 2
    ScreenShiftY = ScreenHeight / 2
    
    If D3D Is Nothing Then: Set D3D = dx.Direct3DCreate
    If D3D Is Nothing Then
        S2DLog.Add "Error initializing D3D"
        Exit Function
    End If
    
    S2DLog.Add "D3D initialized"
    
    If D3DX Is Nothing Then: Set D3DX = New D3DX8
    If D3DX Is Nothing Then
        S2DLog.Add "Error initializing D3DX Object"
        Exit Function
    End If
    
    S2DLog.Add "D3DX Object initialized"
    
    EnumerateAdapters
    EnumerateDevices 0
    EnumerateHardware 1, 0
    
    S2DLog.Add "Enumeration successful"
    
    D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, DisplayMode
    D3D.GetDeviceCaps D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Caps
    
    With PresentParameters
        .Windowed = True
        .hDeviceWindow = hwnd
        .BackBufferCount = 1
        .BackBufferFormat = DisplayMode.Format
        .BackBufferWidth = ScreenWidth
        .BackBufferHeight = ScreenHeight
        .EnableAutoDepthStencil = 1
        .AutoDepthStencilFormat = D3DFMT_D16
        .SwapEffect = D3DSWAPEFFECT_COPY '_VSYNC
        .MultiSampleType = D3DMULTISAMPLE_NONE
    End With
    
    S2DLog.Add "Display Setup successful"
    
    If HardwareVertexProcessing = False Then
        MaximumActiveLights = 8
    End If
    
    If Not EnableLight Then MaximumActiveLights = 0
    
    If HardwareAcceleration Then
        If HardwareVertexProcessing Then
            Set D3DDevice = D3D.CreateDevice(0, D3DDEVTYPE_HAL, hwnd, D3DCREATE_HARDWARE_VERTEXPROCESSING, PresentParameters)
        Else
            Set D3DDevice = D3D.CreateDevice(0, D3DDEVTYPE_HAL, hwnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, PresentParameters)
        End If
    Else
        If HardwareVertexProcessing Then
            Set D3DDevice = D3D.CreateDevice(0, D3DDEVTYPE_REF, hwnd, D3DCREATE_HARDWARE_VERTEXPROCESSING, PresentParameters)
        Else
            Set D3DDevice = D3D.CreateDevice(0, D3DDEVTYPE_REF, hwnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, PresentParameters)
        End If
    End If
    
    If D3DDevice Is Nothing Then: Set D3DDevice = D3D.CreateDevice(0, D3DDEVTYPE_SW, hwnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, PresentParameters)
    If D3DDevice Is Nothing Then
        Unload
        S2DLog.Add "Error initializing D3DDevice"
        Exit Function
    End If
    
    S2DLog.Add "D3D Device successfully loaded"
    
    With D3DDevice
        .SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
        .SetRenderState D3DRS_DIFFUSEMATERIALSOURCE, D3DMCS_COLOR1

        If MaximumActiveLights > 0 Then
            .SetRenderState D3DRS_LIGHTING, 1
            .SetVertexShader lFVF
        Else
            .SetRenderState D3DRS_LIGHTING, 0
            .SetVertexShader vFVF
        End If
        
        .SetRenderState D3DRS_SPECULARENABLE, 0
        .SetRenderState D3DRS_ALPHAREF, 8
        .SetRenderState D3DRS_ALPHAFUNC, D3DCMP_GREATEREQUAL
        .SetRenderState D3DRS_ALPHATESTENABLE, 1
        .SetRenderState D3DRS_ALPHABLENDENABLE, 1
        .SetRenderState D3DRS_ZENABLE, 1
    End With
    
    S2DLog.Add "Render States successfully set"
    
    Dim matDefault As D3DMATRIX
    Dim matOrtho As D3DMATRIX
    Dim matWorld As D3DMATRIX
    
    D3DXMatrixIdentity matDefault
    D3DXMatrixIdentity matWorld
    D3DXMatrixOrthoLH matOrtho, ScreenWidth, -ScreenHeight, 100, 0

    D3DDevice.SetTransform D3DTS_VIEW, matDefault
    D3DDevice.SetTransform D3DTS_PROJECTION, matOrtho
    D3DDevice.SetTransform D3DTS_WORLD, matDefault
    
End Function

Public Function Resize(Width As Integer, Height As Integer)
    
    ScreenWidth = Width / ZoomFactor
    ScreenHeight = Height / ZoomFactor
    
End Function

Public Function SetRenderMode(Mode As RenderMode)
    
    Select Case Mode
        Case 0: D3DDevice.SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID
        Case 1: D3DDevice.SetRenderState D3DRS_FILLMODE, D3DFILL_WIREFRAME
        Case 2: D3DDevice.SetRenderState D3DRS_FILLMODE, D3DFILL_POINT
    End Select
    
End Function

Public Function Unload()

    UnloadMeshes
    Set D3DDevice = Nothing
    Set D3DX = Nothing
    Set D3D = Nothing
    Set DirectX = Nothing
    
End Function

Public Function Clear()
On Error Resume Next
    D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, vbBlack, 1, 0
    
End Function

Public Function BeginScene()
On Error Resume Next
    D3DDevice.BeginScene
    
End Function

Public Function EndScene()
On Error Resume Next
    D3DDevice.EndScene
    CurrentTexture = -1
    
End Function

Public Function Flip(Optional OverrideDestination As Long)
On Error Resume Next

    SourceRect.Right = ScreenWidth * ZoomFactor
    SourceRect.Bottom = ScreenHeight * ZoomFactor
    D3DDevice.Present SourceRect, ByVal 0, OverrideDestination, ByVal 0
    
End Function

Public Function InitializeLight(Color As Long)
    
    On Error GoTo 1
    
    If MaximumActiveLights > 0 Then
        Dim Mtrl As D3DMATERIAL8, Col As D3DCOLORVALUE
        Col.A = 1: Col.r = 1: Col.g = 1: Col.B = 1
        Mtrl.Ambient = Col
        Mtrl.diffuse = Col
        D3DDevice.SetMaterial Mtrl
        Dim C As ColorRGB
        C = SplitColor(Color)
        D3DDevice.SetRenderState D3DRS_AMBIENT, D3DColorRGBA(C.r, C.g, C.B, 255)
    End If
    Exit Function
1
    S2DLog.Add "Error while initializing Light"

End Function

Public Function LoadMeshFromFile(File As String) As Integer
    
    On Error GoTo 1
    
    Dim tFilename As String
    tFilename = GetFileName(File)
    
    Dim i As Integer
    For i = 0 To MeshCount
        If Meshes(i).FileName = tFilename Then
            S2DLog.Add "Mesh already loaded """ & FileName & """"
            LoadMeshFromFile = i
            Exit Function
        End If
        If Meshes(i).FileName = "" Then
            S2DLog.Add "Using free Mesh Slot"
            CurrentMesh = i
            GoTo SkipAllocate
        End If
    Next
    
    MeshCount = MeshCount + 1
    ReDim Preserve Meshes(MeshCount)
    CurrentMesh = MeshCount
    
SkipAllocate:
    
    Dim mtrlBuffer As D3DXBuffer
    Dim TextureFile As String
    
    Meshes(MeshCount).FileName = tFilename
    Set Meshes(MeshCount).Mesh = D3DX.LoadMeshFromX(File, D3DXMESH_MANAGED, D3DDevice, Nothing, mtrlBuffer, Meshes(MeshCount).MaterialCount)
    If Meshes(MeshCount).Mesh Is Nothing Then
        Meshes(MeshCount).FileName = ""
        Set Meshes(MeshCount).Mesh = Nothing
        S2DLog.Add "Error loading Mesh """ & File & """"
        Exit Function
    End If
    
    ReDim Meshes(MeshCount).MeshMaterials(Meshes(MeshCount).MaterialCount) As D3DMATERIAL8
    ReDim Meshes(MeshCount).MeshTextures(Meshes(MeshCount).MaterialCount) As Direct3DTexture8
    
    For i = 0 To Meshes(MeshCount).MaterialCount - 1
        D3DX.BufferGetMaterial mtrlBuffer, i, Meshes(MeshCount).MeshMaterials(i)
        Meshes(MeshCount).MeshMaterials(i).Ambient = Meshes(MeshCount).MeshMaterials(i).diffuse
        TextureFile = D3DX.BufferGetTextureName(mtrlBuffer, i)
        If TextureFile <> "" Then
            Set Meshes(MeshCount).MeshTextures(i) = D3DX.CreateTextureFromFileEx(D3DDevice, App.Path & "\" & TextureFile, D3DX_DEFAULT, D3DX_DEFAULT, D3DX_DEFAULT, 0, D3DFMT_UNKNOWN, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)
        End If
    Next i
    
    S2DLog.Add "Mesh """ & File & """ successfully loaded"
    S2DLog.Add "Number of Faces in Mesh: " & Meshes(MeshCount).Mesh.GetNumFaces
    S2DLog.Add "Number of Vertices in Mesh: " & Meshes(MeshCount).Mesh.GetNumVertices
    LoadMeshFromFile = MeshCount
    
    Exit Function
1
    Meshes(MeshCount).FileName = ""
    Set Meshes(MeshCount).Mesh = Nothing
    S2DLog.Add "Error creating Mesh """ & File & """"
     
End Function

Public Function UnloadMeshes()
    
    On Error GoTo 1
    
    For i = 0 To MeshCount
        Set Meshes(i).Mesh = Nothing
        For B = 0 To Meshes(i).MaterialCount - 1
            Set Meshes(i).MeshTextures(B) = Nothing
        Next B
    Next i
    
    Erase Meshes
    S2DLog.Add "All Meshes unloaded successfully"
    Exit Function
1
    S2DLog.Add "Error while unloading Meshes"
    
End Function

Public Function RenderMesh(ID As Integer, X As Integer, y As Integer, Z As Integer, Optional ScaleFactor As Double = 1, Optional Rotation As Double = 0)
    
    Dim WorldMatrix As D3DMATRIX
    Dim matTranslation As D3DMATRIX
    Dim matScaling As D3DMATRIX
    Dim matRotate As D3DMATRIX

    D3DXMatrixScaling matScaling, ScaleFactor, ScaleFactor, ScaleFactor
    Dim toX As Integer
    Dim toY As Integer
    toX = X - ScreenWidth / 2
    toY = y - ScreenHeight / 2
    D3DXMatrixTranslation matTranslation, toX, toY, Z
    D3DXMatrixMultiply WorldMatrix, matScaling, matTranslation
    D3DXMatrixRotationZ matRotate, Rotation
    D3DXMatrixMultiply WorldMatrix, WorldMatrix, matRotate
    D3DDevice.SetTransform D3DTS_WORLD, WorldMatrix
 
    For i = 0 To Meshes(ID).MaterialCount - 1
        
        D3DDevice.SetMaterial Meshes(ID).MeshMaterials(i)
        D3DDevice.SetTexture 0, Meshes(ID).MeshTextures(i)
        Meshes(ID).Mesh.DrawSubset i
        
    Next i
    
    D3DXMatrixTranslation WorldMatrix, 0, 0, 0
    D3DDevice.SetTransform D3DTS_WORLD, WorldMatrix
    
End Function

Public Function CreateFont(Optional Name As String = "Verdana", Optional Size As Integer = 18, Optional Bold As Boolean = False, Optional Italic As Boolean = False, Optional Strikethrough As Boolean = False, Optional Underline As Boolean = False) As Integer
    
    On Error GoTo 1
    
    Dim MainFontDesc As IFont
    Dim tempFont As New StdFont

    tempFont.Name = Name
    tempFont.Size = Size
    tempFont.Bold = Bold
    tempFont.Italic = Italic
    tempFont.Strikethrough = Strikethrough
    tempFont.Underline = Underline

    FontCount = FontCount + 1
    ReDim Preserve Fonts(FontCount)
    
    Set MainFontDesc = tempFont
    Set Fonts(FontCount) = D3DX.CreateFont(D3DDevice, MainFontDesc.hFont)
    
    CreateFont = FontCount
    S2DLog.Add "Font created successfully"
    Exit Function
    
1
    S2DLog.Add "Error creating Font"

End Function

Public Function RenderFont(ID As Integer, X As Integer, y As Integer, Z As Integer, Text As String, Optional Color As Long = vbWhite, Optional Shadow As Boolean = True, Optional Alpha As Integer = 255)
      
    Dim WorldMatrix As D3DMATRIX
    
    D3DXMatrixTranslation WorldMatrix, 0, 0, Z
    D3DDevice.SetTransform D3DTS_WORLD, WorldMatrix
    
    FontRect.Left = X
    FontRect.Top = y
    FontRect.Right = ScreenWidth
    FontRect.Bottom = ScreenHeight
                
    Dim rC As ColorRGB
    rC = SplitColor(Color)
    
    If Shadow Then
        Dim OldRect As RECT
        OldRect = FontRect
        FontRect.Left = FontRect.Left + 2
        FontRect.Top = FontRect.Top + 2
        
        D3DX.DrawText Fonts(ID), D3DColorARGB(Alpha, rC.r / 2, rC.g / 2, rC.B / 2), Text, FontRect, DT_TOP
        FontRect = OldRect
    End If
    
    D3DX.DrawText Fonts(ID), D3DColorARGB(Alpha, rC.r, rC.g, rC.B), Text, FontRect, DT_TOP
    
    D3DXMatrixTranslation WorldMatrix, 0, 0, 0
    D3DDevice.SetTransform D3DTS_WORLD, WorldMatrix
    
End Function

Public Function CreateLight(X As Integer, y As Integer, Z As Integer, Color As Long) As Integer
    
    On Error GoTo 1
    
    If MaximumActiveLights > 0 Then
        LightCount = LightCount + 1
        ReDim Preserve Lights(LightCount)
    
        Lights(LightCount).Type = D3DLIGHT_POINT
        
        X = X - BackBufferWidth / 2
        y = y - BackBufferHeight / 2
        
        Lights(LightCount).Position = MakeVector(CSng(X), CSng(y), CSng(Z))
        
        Dim rgb As ColorRGB
        rgb = SplitColor(Color)
        
        Dim cbase As Double
        Dim cb, cr, cg, ca
        cbase = 1 / 255
        If rgb.B > 0 Then cb = cbase * rgb.B
        If rgb.r > 0 Then cr = cbase * rgb.r
        If rgb.g > 0 Then cg = cbase * rgb.g
        
        Lights(LightCount).diffuse.B = cb
        Lights(LightCount).diffuse.g = cg
        Lights(LightCount).diffuse.r = cr
        Lights(LightCount).diffuse.A = 1
        
        Lights(LightCount).Range = 1000
        Lights(LightCount).Attenuation1 = 0.01
    
        D3DDevice.SetLight LightCount, Lights(LightCount)
        D3DDevice.LightEnable LightCount, 1
        
        CreateLight = LightCount
        S2DLog.Add "Light created at " & X & "," & y & "," & Z
    End If
    Exit Function
1
    S2DLog.Add "Error while creating Lightsource"
    
End Function

Public Function MoveLight(ID As Integer, X As Integer, y As Integer, Z As Integer)
    
    If MaximumActiveLights > 0 Then
        Dim light As D3DLIGHT8
        D3DDevice.GetLight ID, light
        
        Dim toX As Single
        Dim toY As Single
        toX = X - (BackBufferWidth / 2)
        toY = y - (BackBufferHeight / 2)
        
        light.Position = MakeVector(toX, toY, CSng(Z))
        D3DDevice.SetLight ID, light
     End If
     
End Function

Public Function ChangeLightColor(ID As Integer, Color As Long)
    
    If MaximumActiveLights > 0 Then
        Dim light As D3DLIGHT8
        D3DDevice.GetLight ID, light
        
        Dim rgb As ColorRGB
        rgb = SplitColor(Color)
        
        Dim cbase As Double
        Dim cb, cr, cg, ca
        cbase = 1 / 255
        If rgb.B > 0 Then cb = cbase * rgb.B
        If rgb.r > 0 Then cr = cbase * rgb.r
        If rgb.g > 0 Then cg = cbase * rgb.g
        
        light.diffuse.B = cb
        light.diffuse.g = cg
        light.diffuse.r = cr
        light.diffuse.A = 1
        D3DDevice.SetLight ID, light
    End If
    
End Function

Public Function ChangeLightIntensity(ID As Integer, Value As Double)
    
    If MaximumActiveLights > 0 Then
        Dim light As D3DLIGHT8
        D3DDevice.GetLight ID, light
        light.Attenuation1 = Value
        D3DDevice.SetLight ID, light
    End If
    
End Function

Private Sub Class_Initialize()
    
    ZoomFactor = 1
    LightCount = -1
    MeshCount = -1
    FontCount = -1
    
End Sub


