mread3ds.bas

3ds文件浏览程序

        If Not ReadShort(m_Ptr, s) Then Exit Function 'spline terms
        KeyField.Spline(i) = s
        's indicates which of the following are present
        'Debug.Print Hex(s)
        If s Then
            If s And 1 Then
                If Not ReadFloat(m_Ptr, f) Then Exit Function 'tension
                KeyField.Tension(i) = f
            End If
            If s And 2 Then
                If Not ReadFloat(m_Ptr, f) Then Exit Function 'continuity
                KeyField.Continuity(i) = f
            End If
            If s And 4 Then
                If Not ReadFloat(m_Ptr, f) Then Exit Function 'bias
                KeyField.Bias(i) = f
            End If
            If s And 8 Then
                If Not ReadFloat(m_Ptr, f) Then Exit Function 'ease to
                KeyField.EaseTo(i) = f
            End If
            If s And 16 Then
                If Not ReadFloat(m_Ptr, f) Then Exit Function 'ease from
                KeyField.EaseFrom(i) = f
            End If
        End If
        Select Case MyChunk.ID
        Case POS_TRACK_TAG
            If Not Read3Floats(m_Ptr, v) Then Exit Function
            KeyField.SetXYZ i, v
        Case ROT_TRACK_TAG:
            If Not ReadFloat(m_Ptr, f) Then Exit Function 'angle
            If Not Read3Floats(m_Ptr, v) Then Exit Function
            KeyField.SetXYZ i, v, f
        Case SCL_TRACK_TAG:
            If Not Read3Floats(m_Ptr, v) Then Exit Function
            KeyField.SetXYZ i, v
        Case MORPH_TRACK_TAG:
            If Not Read3DSString(Name) Then GoTo ErrorHandler
            KeyField.Name(i) = Name
        Case HIDE_TRACK_TAG, FOV_TRACK_TAG, ROLL_TRACK_TAG, FALL_TRACK_TAG, HOT_TRACK_TAG:
            If Not ReadFloat(m_Ptr, f) Then Exit Function
            KeyField.x(i) = f
        Case COL_TRACK_TAG
            If Not Read3Floats(m_Ptr, v) Then Exit Function
            KeyField.SetXYZ i, v
        Case Else: Debug.Assert 0
        End Select
        If m_Ptr > MyChunkEnd Then
            Debug.Assert 0
            Exit For
        End If
    Next
    '
    ReadTrackHeader = True
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Debug.Print Err.Description
    Exit Function
    Resume Next
End Function


'----------------------------------------------------
'UTILITY ROUTINES
'----------------------------------------------------
'----------------------------------------------------
' Read vertices
'----------------------------------------------------
Public Function ReadPointArray(Vertices As MFVec3f)
Dim Count%, i&, j&, Value!, vec!(0 To 2)
On Error GoTo ErrorHandler
    If Not ReadShort(m_Ptr, Count) Then Exit Function
    Vertices.Count = Count
    For j = 0 To Count - 1
        For i = 0 To 2
            If Not ReadFloat(m_Ptr, Value) Then Exit Function
            vec(i) = Value
            'get bounding box
            Select Case i
            Case 0 'x
                If Value < lx Then
                    lx = Value
                End If
                If Value > rx Then
                    rx = Value
                End If
            Case 1 'y
                If Value < by Then
                    by = Value
                End If
                If Value > ty Then
                    ty = Value
                End If
            Case 2 'z
                If Value < bz Then
                    bz = Value
                End If
                If Value > fz Then
                    fz = Value
                End If
            End Select
        Next
        Vertices.SetValue j, vec
    Next
    ReadPointArray = True
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Exit Function
End Function


'----------------------------------------------------
' Read the materials used by the group
'----------------------------------------------------
Public Function ReadMeshMatGroup(MatFaces As MFLong) 'mats&(), Matcount&,
Dim Count%, FaceIndex%, Name$
Dim Index&, i&
On Error GoTo ErrorHandler
    ' Read the material name
    If Not Read3DSString(Name) Then Exit Function

    ' look up its index
    Index = Materials.GetIndex(Name)
    '
    ' Read the number of faces to map
    If Not ReadShort(m_Ptr, Count) Then Exit Function
    ' set this index to the current material
    For i = 0 To Count - 1
        If Not ReadShort(m_Ptr, FaceIndex) Then Exit Function
        MatFaces.Value(CLng(FaceIndex)) = Index
    Next

    ReadMeshMatGroup = True
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Debug.Print Err.Description
    Exit Function
    Resume Next
End Function

'----------------------------------------------------
' Read polygons
'----------------------------------------------------
Public Function ReadFaceArray(Faces As MFVec3L)
Dim Count%, v&(0 To 2), i&, j&, Value%
On Error GoTo ErrorHandler
    ' Read the count
    If Not ReadShort(m_Ptr, Count) Then Exit Function
    Faces.Count = Count '
    ' Read the faces
    For j = 0 To Count - 1
        ' Read the triangle
        For i = 0 To 2
            If Not ReadShort(m_Ptr, Value) Then Exit Function
            v(i) = Value
        Next
        Faces.SetValue j, v
        ' Read the visible edges and discard?
        If Not ReadShort(m_Ptr, Value) Then Exit Function
    Next
    ReadFaceArray = True
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Exit Function
End Function

'----------------------------------------------------
'Reads in the mapping list/texture coords. for the current mesh object '
'----------------------------------------------------
Public Function ReadTexVerts(TexCoords As MFVec2f) As Boolean
Dim Count%, v!(0 To 1), i&, Value%
On Error GoTo ErrorHandler
    ' Read the count
    If Not ReadShort(m_Ptr, Count) Then Exit Function
    TexCoords.Count = Count
    For i = 0 To Count - 1
        If Not ReadFloat(m_Ptr, v(0)) Then Exit Function
        If Not ReadFloat(m_Ptr, v(1)) Then Exit Function
        TexCoords.SetValue i, v
    Next
    ReadTexVerts = True
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Exit Function
End Function

'----------------------------------------------------
' Read a Percent Chunk
' assumes the chunk header is not yet read
'----------------------------------------------------
Public Function ReadPercentage(ParentNode As Object, Value!) As Boolean
Dim Chunk As Chunk3DS
Dim ChunkStart&
Dim svalue%
On Error GoTo ErrorHandler
    ChunkStart = m_Ptr
    If Not ReadChunkHeader(Chunk) Then Exit Function
    Select Case Chunk.ID
    Case INT_PERCENTAGE
        If Not ReadShort(m_Ptr&, svalue) Then Exit Function
        Value = svalue / 100
        ReadPercentage = True
    Case FLOAT_PERCENTAGE
        If Not ReadFloat(m_Ptr, Value) Then Exit Function
        ReadPercentage = True
    Case Else
        Debug.Assert 0
        If Not SkipChunk(ParentNode, Chunk) Then Exit Function
        Exit Function
    End Select
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Exit Function
End Function

'----------------------------------------------------
' Read a color definition
' assumes header not yet read
'----------------------------------------------------
Public Function ReadColor(ParentNode As Object, red!, green!, blue!)
Dim Chunk As Chunk3DS
Dim ChunkStart&, tmp As Byte
On Error GoTo ErrorHandler
    ChunkStart = m_Ptr
    If Not ReadChunkHeader(Chunk) Then Exit Function
    Select Case Chunk.ID
    Case COLOR_F, LIN_COLOR_F:
        If Not ReadFloat(m_Ptr, red) Then Exit Function
        If Not ReadFloat(m_Ptr, green) Then Exit Function
        If Not ReadFloat(m_Ptr, blue) Then Exit Function
    Case COLOR_24, LIN_COLOR_24:
        If Not ReadByte(m_Ptr, tmp) Then Exit Function
        red = tmp / 255
        If Not ReadByte(m_Ptr, tmp) Then Exit Function
        green = tmp / 255
        If Not ReadByte(m_Ptr, tmp) Then Exit Function
        blue = tmp / 255
    Case Else
        Debug.Assert 0
        If Not SkipChunk(ParentNode, Chunk) Then Exit Function
        Exit Function
    End Select
    ReadColor = True
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Exit Function
End Function

'----------------------------------------------------
' Read a string to a '\0'
' assumes header already read
'----------------------------------------------------
Public Function Read3DSString(Name$) As Boolean
Dim c&, i&, s$, Value As Byte
Const MAX_SIZE = 255
On Error GoTo ErrorHandler
    s = String(256, Chr$(0))
    Do
        CopyToByteFromPtr Value, m_Ptr, 1
        m_Ptr = m_Ptr + 1
        Debug.Print Chr$(Value), Value
        If Value = 0 Then Exit Do
        i = i + 1
        If i < MAX_SIZE Then
            Mid$(s, i, 1) = Chr$(Value)
        End If
    Loop
    Name = Left$(s, i)
    Debug.Print Name
    Read3DSString = True
'----------------------------------------------------
Exit Function
ErrorHandler:
    Debug.Assert 0
    Exit Function
    Resume Next
End Function

'----------------------------------------------------
'DEBUG UTILITY ROUTINES
'----------------------------------------------------
Public Function Offset&()
    Offset = m_Ptr - base_Ptr
End Function

Public Sub IncPtr(n&)
    m_Ptr = m_Ptr + n
End Sub

'we don't want to read past eof if we get lost
Public Sub GetSize(ChunkStart&, ChunkEnd&, Chunk As Chunk3DS)
    ChunkStart = m_Ptr - SizeofChunk
    ChunkEnd = ChunkStart + Chunk.Length
    If ChunkStart > ChunkEnd Then
        Debug.Assert 0
    End If
    If ChunkEnd > FileEnd Then
        Debug.Assert 0
        ChunkEnd = FileEnd
    End If
End Sub