cgl.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 = "CGL"
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: main class which responds to the ocx.
' manages the drawing and viewing states
'AUTHOR: edx - [e-mail], Oct 98 - all rights reserved
'HISTORY: -
'NOTES: This app doesn't use the ocx timer, and only paints when
'needed, so it must call gCtl.Render when whenever it changes
'the scene, view, or display mode.
'*************************************************************************
Dim m_bDragging As Boolean
Dim m_MouseX&, m_MouseY&
Dim m_StartX&, m_StartY&
Dim m_Center!(0 To 2)
Dim m_GLEditState As GLEditStates
Dim m_OldGLEditState As GLEditStates
Dim m_ShowGrid As Boolean
'
Dim m_View As GLViews
Dim m_NearPlaneP!, m_NearPlaneO!, m_FarPlane!
Dim m_FOV!, m_EyeDist!, m_OrthoBox!
Dim m_OL!, m_OR!, m_OB!, m_OT!
Dim m_Grid As Boolean
Dim m_ScaleFactor!
Dim m_DefLightPos!(0 To 2)

Private Sub Class_Initialize()
    m_NearPlaneO = -10000
    m_NearPlaneP = 1
    m_FarPlane = 10000
    m_FOV = 45
    m_EyeDist = 200
    m_OrthoBox = 100
    m_OL = -m_OrthoBox
    m_OR = m_OrthoBox
    m_OB = -m_OrthoBox
    m_OT = m_OrthoBox
    m_ScaleFactor = 1
    m_DefLightPos(1) = 200
    m_DefLightPos(2) = 150
End Sub

Public Sub Init()
    'do pre-GL stuff here - set pf
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
    'glEnable GL_CULL_FACE
    glPolygonMode GL_FRONT_AND_BACK, GL_LINE
    glDisable GL_LIGHTING
    glShadeModel GL_SMOOTH
    With gCtl.Camera
        .FarPlane = m_FarPlane
        .NearPlane = m_NearPlaneO
        .FieldOfView = m_FOV
        .SetEyePos 0, 0, m_EyeDist
        .SetTargetPos 0, 0, 0
        .SetOrtho m_OL, m_OR, m_OB, m_OT
        .SetOrthoEyePos 0, 0, m_EyeDist
    End With
    '
    With gCtl
        .Grid = glxGridX
        .GridStep = 10
        .SetWorldSize 400, 400, 400
        .Axis = glxXYZ
        .MouseRotate = True
        .Trackball.Animate = False
    End With
    '
    glEnableClientState GL_VERTEX_ARRAY
    glEnableClientState GL_NORMAL_ARRAY
    glEnableClientState GL_TEXTURE_COORD_ARRAY
    '
    EditState = STATE_SELECT
End Sub

'----------------------------------------------------
Public Sub Draw()
    With gCtl.Lights.Item(liLight0)
        .SetPosition m_DefLightPos(0), m_DefLightPos(1), m_DefLightPos(2)
    End With
    With gCtl
        .Trackball.Update
        If m_Grid Then .DrawGrids
    End With
    If ReadyToDraw Then
        glPushMatrix
        glRotatef -90, 1, 0, 0
        glTranslatef -m_Center(0), -m_Center(1), -m_Center(2)
        'no good, fucks up the normals
        'glScalef m_ScaleFactor, m_ScaleFactor, m_ScaleFactor
        Scene.Draw
        glPopMatrix
    Else
        'test object
        'gCtl.Shapes.SolidTorus 10, 50, 16, 32
    End If
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)
    If Button = 1 Then
        m_bDragging = True
        m_StartX = x
        m_StartY = y
    ElseIf Button = 2 Then
        m_OldGLEditState = EditState
        EditState = STATE_ARCROTATE
    End If
    m_MouseX = x
    m_MouseY = y
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
            'to manipulate the model....
            With gCtl.Camera
                Select Case GL.EditState
                Case STATE_SELECT:
                Case STATE_ZOOM: Zoom x, y
                Case STATE_ARCROTATE
                Case STATE_PAN: Pan x, y
                End Select
            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)
    If Button = 1 Then
    ElseIf Button = 2 Then
        EditState = m_OldGLEditState
    End If
End Sub


'------------------------------------------------------------
Public Property Get EditState() As GLEditStates
    EditState = m_GLEditState
End Property

Public Property Let EditState(ByVal NewValue As GLEditStates)
    m_GLEditState = NewValue
    With frmMain
        Select Case m_GLEditState
        Case STATE_SELECT: .SetCursor "select"
        Case STATE_ZOOM: .SetCursor "zoom"
        Case STATE_PAN: .SetCursor "pan"
        End Select
    End With
End Property

'------------------------------------------------------------
Public Property Let View(ByVal NewValue As GLViews)
Dim s$
'leave the target the same in ortho views
With gCtl.Camera
    m_View = NewValue
    If m_View = GLVIEW_PERSPECTIVE Then
        .NearPlane = m_NearPlaneP
        gCtl.MouseRotate = True
    Else:
        .NearPlane = m_NearPlaneO
        gCtl.MouseRotate = False
        gCtl.Trackball.Reset
    End If
    Select Case NewValue
    Case GLVIEW_PERSPECTIVE:
        .SetEyePos 0, 0, m_EyeDist
        .SetTargetPos 0, 0, 0
        .View = glxPerspective '0
        s = "Perspective"
        gCtl.Grid = glxGridX
    Case Else
        .SetTargetPos 0, 0, 0
        Select Case NewValue
        Case GLVIEW_TOP:
            .SetOrthoEyePos 0, m_EyeDist, 0
            s = "Top" '2
            gCtl.Grid = glxGridX
        Case GLVIEW_FRONT:
            .SetOrthoEyePos 0, 0, m_EyeDist
            s = "Front" '3
            gCtl.Grid = glxGridY
        Case GLVIEW_LEFT:
            .SetOrthoEyePos -m_EyeDist, 0, 0
            s = "Left" '5
            gCtl.Grid = glxGridYZ
        Case GLVIEW_RIGHT:
            .SetOrthoEyePos m_EyeDist, 0, 0
            s = "Right" '7
            gCtl.Grid = glxGridYZ
        Case GLVIEW_BACK:
            .SetOrthoEyePos 0, 0, -m_EyeDist
            s = "Back" '6
            gCtl.Grid = glxGridY
        Case GLVIEW_BOTTOM:
            .SetOrthoEyePos 0, -m_EyeDist, 0
            s = "Bottom" '4
            gCtl.Grid = glxGridX
        Case Else: Debug.Assert 0
        End Select
        .View = m_View
        m_SetOrtho
    End Select
End With
frmMain.SetStatusView " " & s & " view"
gCtl.Render
End Property

'---------------------------------------------------------
'default frustrum is 200x200
Public Sub Zoom(x!, y!)
Dim IncY!, Speed!, ZoomInc!
Dim ex!, ey!, ez!
'
With gCtl.Camera
    IncY = y - m_MouseY
    If IncY = 0 Then Exit Sub
    'zoom speed adjustment
    Speed = 1
    If m_EyeDist < 1 Then Speed = 3
    ZoomInc = IncY * Speed: ' Debug.Print "zoomInc:" & ZoomInc
    If ZoomInc > 0 Then
        m_EyeDist = m_EyeDist * 1.1 * Speed
    Else
        m_EyeDist = m_EyeDist * 0.9 * Speed
    End If
    'inner range limit
    If m_EyeDist < 0.05 Then m_EyeDist = 0.05
    'outer range limit
    If m_EyeDist > m_FarPlane * 0.95 Then m_EyeDist = m_FarPlane * 0.95
    Debug.Print "z" & m_EyeDist
    Select Case m_View
    Case GLVIEW_PERSPECTIVE:
        .GetEyePos ex, ey, ez
        .SetEyePos ex, ey, m_EyeDist
    Case Else
        m_SetOrtho
    End Select
End With
End Sub

'---------------------------------------------------------
Private Sub m_SetOrtho()
Dim l#, r#, b#, t#
    r = m_EyeDist / 2
    l = -r
    b = l
    t = r
    gCtl.Camera.SetOrtho l, r, b, t
    'grid spacing hack.
    With gCtl
    If r < 20 Then
        .GridStep = 1
        .SetWorldSize 200, 200, 200
        'debug
    ElseIf r < 100 Then
        gCtl.GridStep = 10
        .SetWorldSize 400, 400, 400
    Else
        gCtl.GridStep = 100
        r = r * 10
        .SetWorldSize 1000, 1000, 1000
    End If
    End With
End Sub

'---------------------------------------------------------
'might want to add code to adjust the clipping planes when
'the view is panned and model starts to get clipped.
'---------------------------------------------------------
Public Sub Pan(x!, y!)
Dim IncX!, IncY!, nx!, ny!
Dim m_ZoomFactor!, ex!, ey!, ez!, tx!, ty!, tz!
With gCtl.Camera
    m_ZoomFactor = m_EyeDist / 200
    IncX = m_MouseX - x
    IncY = m_MouseY - y
    .GetEyePos ex, ey, ez
    .GetTargetPos tx, ty, tz
    ny = -IncY * 0.4 * m_ZoomFactor
    nx = IncX * 0.4 * m_ZoomFactor
    Select Case m_View
    Case GLVIEW_PERSPECTIVE:
        ex = ex + nx
        ey = ey + ny
        tx = tx + nx
        ty = ty + ny
    Case glxTop
        tx = tx + nx
        ex = ex + nx
        tz = tz - ny
        ez = ez - ny
    Case glxBottom
        tx = tx + nx
        ex = ex + nx
        tz = tz - ny
        ez = ez - ny
    Case glxFront
        tx = tx + nx
        ex = ex + nx
        ty = ty + ny
        ey = ey + ny
    Case glxBack
        tx = tx - nx
        ex = ex - nx
        ty = ty + ny
        ey = ey + ny
    Case glxLeft
        tz = tz - nx
        ez = ez - nx
        ty = ty + ny
        ey = ey + ny
    Case glxRight
        tz = tz + nx
        ez = ez + nx
        ty = ty + ny
        ey = ey + ny
    Case Else
        Debug.Assert 0
    End Select
    .SetEyePos ex, ey, ez
    .SetTargetPos tx, ty, tz
End With
End Sub

'---------------------------------------------------------
'show or hide the grid
Public Property Get Grid() As Boolean
    Grid = m_Grid
End Property

Public Property Let Grid(ByVal NewValue As Boolean)
    m_Grid = NewValue
    gCtl.Render
End Property

'------------------------------------------------------------
'parameters are the bounding box of the model
'rather than moving the points of the model, we translate it to the origin.
'The 'center' is the translation needed to center the object on screen.
'This also adjusts the clipping planes to the model's size.
'------------------------------------------------------------
Public Sub SetCenter(l!, r!, b!, t!, bk!, f!)
Dim x!, y!, z!, s$
Dim w!
    x = r - l
    y = t - b
    z = f - b
    s = Format$(x, "FIXED")
    Debug.Print s
    frmMain.sts.Panels(1) = "Size: " & x & "," & y & "," & z
    m_Center(0) = l + (r - l) / 2
    m_Center(1) = b + (t - b) / 2
    m_Center(2) = bk + (f - bk) / 2
    w = x
    If y > w Then w = y
    If z > w Then w = z
    'If w * 1.3 > m_FarPlane Then
    m_FarPlane = w * 4
    m_NearPlaneO = -m_FarPlane
    'update
    View = m_View
    'End If
End Sub

Public Sub GetCenterv(v!())
Dim i&
For i = 0 To 2
    v(i) = m_Center(i)
Next
End Sub

'---------------------------------------------------------
'3ds chunk. This isn't used.
Public Property Get MasterScale!()
    MasterScale = m_ScaleFactor
End Property

Public Property Let MasterScale(ByVal NewValue!)
    If m_ScaleFactor <> 1 Then Debug.Assert 0
    m_ScaleFactor = NewValue
End Property