cmaterial.cls

3ds文件浏览程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CMaterial"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'*************************************************************************
'FUNCTION: wrapper class for a glxMaterial / glxTexture
'AUTHOR: edx - [e-mail], Oct 98 - all rights reserved
'HISTORY: -
'NOTES: This app is a file parsing demo. It only uses basic material
'properties like color and the main texture map.
'*************************************************************************
Public NodeID As NodeIDConstants
Public ChunkID%
Public TreeNode As Node
Public Parent As CNode
Public Fields As Collection
Public Name$
'
Dim Mat As glxMaterial
Dim Maps As Collection
Dim m_MainMap As CMap
'
'these and the colors are used in GL rendering. Any other
'properties are ignored and kept in the Fields collection.
Public TwoSide As Boolean
Public Decal As Boolean
Dim m_Transparency!

Private Sub Class_Initialize()
    Set Mat = gCtl.NewMaterial
    Mat.face = faceFrontAndBack
    Set Maps = New Collection
    Set Fields = New Collection
End Sub

Private Sub Class_Terminate()
    Set Mat = Nothing
    Set Maps = Nothing
End Sub

'----------------------------------------------------------------------------
'PROPERTIES
'----------------------------------------------------------------------------

'----------------------------------------------------------------------------
Public Sub SetAmbient(r!, g!, b!)
    Mat.SetAmbient r, g, b
End Sub

'----------------------------------------------------------------------------
Public Sub Shininess(v!)
    If v < 0 Or v > 128 Then Debug.Assert 0
    Mat.Shininess = v
End Sub

'----------------------------------------------------------------------------
Public Sub SetDiffuse(r!, g!, b!)
    Mat.SetDiffuse r, g, b
End Sub

Public Sub SetSpecular(r!, g!, b!)
    Mat.SetSpecular r, g, b
End Sub

'----------------------------------------------------------------------------
Public Property Get Transparency!()
    Transparency = m_Transparency
End Property

Public Property Let Transparency(ByVal NewValue!)
    m_Transparency = NewValue
End Property

'----------------------------------------------------------------------------
Public Sub GetColor(r!, g!, b!)
    With Mat
        If .Diffuse(0) <> 0 And .Diffuse(1) <> 0 And .Diffuse(2) <> 0 Then
            r = .Diffuse(0)
            g = .Diffuse(1)
            b = .Diffuse(2)
        ElseIf .Ambient(0) <> 0 And .Ambient(1) <> 0 And .Ambient(2) <> 0 Then
            r = .Ambient(0)
            g = .Ambient(1)
            b = .Ambient(2)
        Else
            r = 1: g = 1: b = 1
        End If
    End With
End Sub

'----------------------------------------------------------------------------
Public Sub SetColor(r!, g!, b!)
    With Mat
        .Ambient(0) = 0.2 * r
        .Ambient(1) = 0.2 * g
        .Ambient(2) = 0.2 * b
        .Diffuse(0) = r
        .Diffuse(1) = g
        .Diffuse(2) = b
        .SetSpecular 0.8, 0.8, 0.8
    End With
End Sub

'----------------------------------------------------------------------------
'create a map object on demand
'----------------------------------------------------------------------------
Public Function GetMap(ChunkID%) As CMap
Dim i&, Map As CMap
    If ChunkID = 0 Then Debug.Assert 0
    For i = 1 To Maps.Count
        If Maps(i).MapID = ChunkID Then
            Set GetMap = Maps(i)
            Exit Function
        End If
    Next
    'don't have one yet, create one
    Set Map = New CMap
    Map.ChunkID = ChunkID
    If ChunkID = MAT_TEXMAP Then
        Set m_MainMap = Map
    End If
    Maps.Add Map
    Set Map.Parent = Me
    Set GetMap = Map
End Function

'----------------------------------------------------------------------------
'we only use the main map for drawing
'----------------------------------------------------------------------------
Public Sub LoadMaps(Path$)
    If Not m_MainMap Is Nothing Then
        m_MainMap.LoadMap Path
    End If
End Sub

'----------------------------------------------------------------------------
'METHODS
'----------------------------------------------------------------------------

'----------------------------------------------------------------------------
Public Function AddField(ChunkID%) As CField
Dim Field As CField
    Set Field = New CField
    Field.ChunkID = ChunkID
    Fields.Add Field
    Set Field.Parent = Me
    Set AddField = Field
End Function

'----------------------------------------------------------------------------
'add this object to the treeview
'----------------------------------------------------------------------------
Public Sub FillTree()
Dim ParentNode As Node, i&, s$, s1$
On Error GoTo ErrorHandler
    If Err Then Debug.Assert 0
    Debug.Print Name
    s = Name
    If Len(s) Then s = ": " & s
    s1 = ChunkName(ChunkID) & s
    With frmMain
        If Parent Is Nothing Then
            If .TV1.Nodes.Count Then Debug.Assert 0
            Set TreeNode = .TV1.Nodes.Add(, , , s1, IMG_MATERIAL)
        Else
            Set ParentNode = Parent.TreeNode
            Set TreeNode = .TV1.Nodes.Add(ParentNode, tvwChild, , s1, IMG_MATERIAL)
        End If
        '
        .TV1.Nodes.Add TreeNode, tvwChild, , "Ambient: " & Round(Mat.Ambient(0), 2) & ", " & Round(Mat.Ambient(1), 2) & ", " & Round(Mat.Ambient(2), 2), IMG_FIELD
        .TV1.Nodes.Add TreeNode, tvwChild, , "Diffuse: " & Round(Mat.Diffuse(0), 2) & ", " & Round(Mat.Diffuse(1), 2) & ", " & Round(Mat.Diffuse(2), 2), IMG_FIELD
        .TV1.Nodes.Add TreeNode, tvwChild, , "Specular: " & Round(Mat.Specular(0), 2) & ", " & Round(Mat.Specular(1), 2) & ", " & Round(Mat.Specular(2), 2), IMG_FIELD
        .TV1.Nodes.Add TreeNode, tvwChild, , "Shininess: " & Mat.Shininess, IMG_FIELD
        .TV1.Nodes.Add TreeNode, tvwChild, , "Transparency: " & m_Transparency & "%", IMG_FIELD
        .TV1.Nodes.Add TreeNode, tvwChild, , "TwoSide: " & TwoSide, IMG_FIELD
        .TV1.Nodes.Add TreeNode, tvwChild, , "Decal: " & Decal, IMG_FIELD
        For i = 1 To Fields.Count
            Fields(i).FillTree
        Next
        For i = 1 To Maps.Count
            Maps(i).FillTree
        Next

    End With
'----------------------------------------------------
    Exit Sub
ErrorHandler:
    Debug.Print Err.Description
    Debug.Assert 0
    Exit Sub
    Resume Next
End Sub

'----------------------------------------------------------------------------
Public Sub TurnWhite()
Dim r!, g!, b!
    'if this is first material and its all black, turn it white
    With Mat
        If .Ambient(0) = 0 And .Ambient(1) = 0 And .Ambient(2) = 0 Then
        If .Diffuse(0) = 0 And .Diffuse(1) = 0 And .Diffuse(2) = 0 Then
            .SetAmbient 1, 1, 1
            .SetDiffuse 1, 1, 1
            .SetSpecular 1, 1, 1
        End If
        End If
    End With
End Sub

'----------------------------------------------------------------------------
'gl drawing
'----------------------------------------------------------------------------
Public Sub SetMaterial()
    If Not m_MainMap Is Nothing Then
        If optWireFrame = False And optTextures = True Then
            Materials.SetMaterial 0 'white
            glEnable GL_TEXTURE_2D
            m_MainMap.SetTexture
        Else
            Mat.SetMaterial
        End If
    Else
        Mat.SetMaterial
    End If
End Sub

Public Sub UnSetMaterial()
    If Not m_MainMap Is Nothing Then
        glDisable GL_TEXTURE_2D
    End If
End Sub

Public Function SetMaterial2(optTextures As Boolean) As glxTexture
Dim Tex1 As glxTexture
Dim Tex2 As glxTexture
    If Not m_MainMap Is Nothing Then
        If optTextures = True Then
            Materials.SetMaterial 0 'white
            glEnable GL_TEXTURE_2D
            'm_MainMap.SetTexture
            Set Tex1 = m_MainMap.Texture.Tex
            Set Tex2 = gCtl.NewTexture
            Tex2.CopyTexture Tex1
            Tex2.SetTexture
            Set SetMaterial2 = Tex2
        Else
            Mat.SetMaterial
        End If
    Else
        Mat.SetMaterial
    End If
End Function