cglm.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 = "CGLM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'*************************************************************************
'FUNCTION: material viewer class which responds to the 2nd ocx.
' displays an array of spheres, one for each material
'AUTHOR: edx - [e-mail], Oct 98 - all rights reserved
'HISTORY: -
'NOTES:
'*************************************************************************
Public m_Textures As Boolean
Dim m_bDragging As Boolean
Dim m_MouseX&, m_MouseY&
Dim m_StartX&, m_StartY&
Dim m_Center!(0 To 2)
Dim m_ShowGrid As Boolean
'
Dim m_EyeDist!
Dim m_OL!, m_OR!, m_OB!, m_OT!
Dim m_Grid As Boolean
Dim m_ScaleFactor!
Dim m_DefLightPos!(0 To 2)
Dim gCtl As glxCtl
Dim ID&
Dim QuadObj&
'
Const ROWCOUNT = 4
Const HSPACE = 2.2
Const VSPACE = 2.5

Private Sub Class_Initialize()
    m_EyeDist = 30
    'm_Grid = True
    m_OL = -4.5
    m_OR = -m_OL
    m_OB = m_OL
    m_OT = m_OR
    m_DefLightPos(2) = 100
    m_Textures = True
End Sub

Private Sub Class_Terminate()
    glDeleteLists ID, 1
End Sub

Public Sub Init()
    Set gCtl = frmMaterials.glxCtl1
End Sub

Public Sub InitGL()
    glClearColor 0.3, 0.3, 0.3, 0
    With gCtl.Lights.Item(liLight0)
        .SetAmbient 0.1, 0.1, 0.1
        .SetDiffuse 1, 1, 1
        .SetPosition m_DefLightPos(0), m_DefLightPos(1), m_DefLightPos(2)
        .Enabled = True
    End With
'    'glFrontFace GL_CCW
'    'glCullFace GL_BACK
'    glPolygonMode GL_FRONT_AND_BACK, GL_FILL
'    glShadeModel GL_SMOOTH
    With gCtl.Camera
        .FarPlane = 100
        .NearPlane = -100
        .SetTargetPos 0, 0, 0
        .SetOrtho m_OL, m_OR, m_OB, m_OT
        .SetOrthoEyePos 0, 0, m_EyeDist
        .View = glxOrtho
    End With
    '
    With gCtl
        .Grid = glxGridY
        .GridStep = 1
    End With
    '
    QuadObj = gluNewQuadric
    gluQuadricTexture QuadObj, GL_TRUE
End Sub

Private Sub Compile()
Dim i&, Count&, FacePtr&, curMat&
Dim Mat As CMaterial
Dim Tex As glxTexture
With gCtl.Shapes
    ID = glGenLists(1)
    glNewList ID, GL_COMPILE_AND_EXECUTE
    Count = Materials.Count
    glPushMatrix
    If Count Then
        glTranslatef -((ROWCOUNT - 1) * HSPACE) / 2, 3.5, 0

        For i = 1 To Count
            Set Mat = Materials.ItemFromIndex(i)
            Set Tex = Mat.SetMaterial2(m_Textures)
            'draw a ball
            gluSphere QuadObj, 1, 32, 32
            If Not Tex Is Nothing Then
                glDisable GL_TEXTURE_2D
                Set Tex = Nothing
            End If
            If i Mod ROWCOUNT Then
                glTranslatef HSPACE, 0, 0
            Else
                glTranslatef -HSPACE * (ROWCOUNT - 1), -VSPACE, 0
            End If
        Next
    End If
    glPopMatrix
    glEndList
End With
End Sub

Public Sub Draw()
Dim s$
    With gCtl.Lights.Item(liLight0)
        .SetPosition m_DefLightPos(0), m_DefLightPos(1), m_DefLightPos(2)
    End With
    glPushMatrix
        If ID = 0 Then
            Compile
        Else
            glCallList ID
        End If
    glPopMatrix
    s = gCtl.GetErr
    If Len(s) Then Debug.Assert 0
End Sub

Public Function Reshape(width&, height&) As Boolean
    Reshape = True
    gCtl.Render
End Function

Public Sub KeyDown(KeyCode%, Shift%)
    Select Case (KeyCode)
    Case vbKeyLeft:
    Case vbKeyRight:
    Case vbKeyUp:
    Case vbKeyDown:
    Case 27:
    Case Else:
    End Select
End Sub

Public Sub KeyPress(KeyAscii As Integer)
Dim s$
    s = Chr$(KeyAscii)
    Select Case (s)
    End Select
End Sub

Public Sub MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Rotate the scene with the left mouse button. '
    If Button = 1 Then
        m_bDragging = True
        m_StartX = x
        m_StartY = y
    ElseIf Button = 2 Then
    End If
End Sub

Public Sub MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
        If m_bDragging Then
'            With gCtl.Camera
'            End With
'            gCtl.Render
        End If
    ElseIf Button = 2 Then
        gCtl.Render
    End If
    m_MouseX = x
    m_MouseY = y
End Sub

Public Sub MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    m_bDragging = False
    If Button = 1 Then
    ElseIf Button = 2 Then
    End If
End Sub



Public Property Get Textures() As Boolean
    Textures = m_Textures
End Property

Public Property Let Textures(ByVal NewValue As Boolean)
    m_Textures = NewValue
    glDeleteLists ID, 1
    ID = 0
End Property