mconstants.bas

3ds文件浏览程序

Attribute VB_Name = "mConstants"
Option Explicit

'----------------------------------------------------
Public gCtl As glxCtl
Public GL As CGL ' main class
Public Scene As CScene 'collection of root nodes
Public Tree3ds As TreeView 'the Treeview the chunks are displayed in
Public fMainForm As frmMain
Public Materials As CMaterials 'collection of materials in the scene
Public ReadyToDraw As Boolean 'flag set while parsing a file
Public ELog$ 'error log produced by parser
Public Textures As CTextures
'----------------------------------------------------
'global state flags
Public optTextures As Boolean
Public optWireFrame As Boolean
'
'----------------------------------------------------
Public Const PI = 3.141592654
Type POINT4F
    p(0 To 3) As Single
End Type

Type POINT3F
    p(0 To 2) As Single
End Type

Type INDEX3L
    p(0 To 2) As Long
End Type

Type INDEX2L
    p(0 To 1) As Long
End Type

Type POINT2F
    p(0 To 1) As Single
End Type

Public Enum GLEditStates
    STATE_SELECT = 1
    STATE_ZOOM = 5
    STATE_ARCROTATE = 6
    STATE_PAN = 7
End Enum
Public Enum GLViews
    GLVIEW_PERSPECTIVE = glxPerspective
    GLVIEW_FRONT = glxFront
    GLVIEW_TOP = glxTop
    GLVIEW_RIGHT = glxRight
    GLVIEW_LEFT = glxLeft
    GLVIEW_BACK = glxBack
    GLVIEW_BOTTOM = glxBottom
End Enum

Dim m_NextNodeID& 'counter for node classes

'----------------------------------------------------
'API
'----------------------------------------------------
Type POINTAPI
        x As Long
        y As Long
End Type

Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Declare Function ClipCursor Lib "user32" (lpRect As RECT) As Long
Declare Function ClipCursorFree Lib "user32" Alias "ClipCursor" (ByVal lpNull As Long) As Long
Declare Sub CopyToByteFromByte Lib "kernel32" Alias "RtlMoveMemory" (Dest As Byte, Src As Byte, ByVal Length&)
Declare Sub CopyToStrFromInt Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest$, Src%, ByVal Length&)
'Declare Sub CopyToIntFromStr Lib "kernel32" Alias "RtlMoveMemory" (Src%, ByVal dest$, ByVal Length&)
'Declare Sub CopyToLongFromStr Lib "kernel32" Alias "RtlMoveMemory" (Src&, ByVal dest$, ByVal Length&)
Declare Sub CopyToPtrFromPtr Lib "kernel32" Alias "RtlMoveMemory" (ByVal DestAddr&, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToByteFromPtr Lib "kernel32" Alias "RtlMoveMemory" (Dest As Byte, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToLongFromPtr Lib "kernel32" Alias "RtlMoveMemory" (Dest&, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToIntegerFromPtr Lib "kernel32" Alias "RtlMoveMemory" (Dest%, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToSingleFromPtr Lib "kernel32" Alias "RtlMoveMemory" (Dest!, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToDoubleFromPtr Lib "kernel32" Alias "RtlMoveMemory" (Dest#, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToStrFromPtr Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest$, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToStrFromLong Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest$, Src&, ByVal Length&)
Declare Sub CopyToTypeFromPtr Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByVal SrcAddr&, ByVal Length&)
Declare Sub CopyToTypeFromType Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Src As Any, ByVal Length&)
'Declare Sub CopyToByteFromPtr Lib "kernel32" Alias "RtlMoveMemory" ( _
'        dest As Byte, ByVal Src&, ByVal Length&)
Declare Function GetOpenFileName& Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME)
Declare Function CreateFileMappingDef& Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile&, ByVal lpFileMappingAttributes&, ByVal flProtect&, ByVal dwMaximumSizeHigh&, ByVal dwMaximumSizeLow&, ByVal lpName As String)
'Declare Function CreateDIBSection256& Lib "gdi32" (ByVal Hdc&, _
'            pBitmapInfo As BITMAPINFO256, ByVal iUsage&, lplpVoid&, _
'            ByVal hSection&, ByVal dwOffset&)
Declare Function CreateFile& Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long)
Declare Function IsCharAlphaNumeric& Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte)

'----------------------------------------------------
'assigns a unique id to each node
'----------------------------------------------------
Public Function NextNodeName&()
    m_NextNodeID = m_NextNodeID& + 1
    NextNodeName = m_NextNodeID
End Function

'----------------------------------------------------
'parsing errors
'----------------------------------------------------
Public Sub LogError(msg$)
ELog = ELog & msg & vbCrLf
End Sub

'---------------------------------------------------------
'* Opens a file using a file mapping object
'You MUST call CloseFile when finished!
'---------------------------------------------------------
Public Function LoadFile(ByVal Filename$, FileHandle&, MapHandle&, ptr&) As Boolean
Dim hFile& ' File handle
Dim hMap& ' Mapping object handle
Dim pv& ' Ptr to mapped file
Dim r&
    On Error GoTo Cleanup
    If Filename = "" Then Exit Function
    ' Map the file into memory.
    hFile = CreateFile(Filename, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, 0, 0)
    If (hFile = INVALID_HANDLE_VALUE) Then GoTo Cleanup
    '
    hMap = CreateFileMappingDef(hFile, 0, PAGE_READONLY, 0, 0, 0)
    If hMap = 0 Then GoTo Cleanup
    '
    pv = MapViewOfFile(hMap, FILE_MAP_READ, 0, 0, 0)
    If pv = 0 Then GoTo Cleanup
    '
    'return the pointer
    ptr = pv
    FileHandle = hFile
    MapHandle = hMap
    LoadFile = True
    Exit Function
Cleanup:
    If pv Then UnmapViewOfFile pv
    If hMap Then CloseHandle hMap
    If hFile <> INVALID_HANDLE_VALUE Then CloseHandle hFile
End Function

'---------------------------------------------------------
' closes a file
'---------------------------------------------------------
Public Sub CloseFile(hFile&, hMap&, ptr&)
    If ptr Then UnmapViewOfFile ptr
    If hMap Then CloseHandle hMap
    If hFile <> INVALID_HANDLE_VALUE Then CloseHandle hFile
End Sub

'------------------------------------
'return pos of last occurence of char$
'------------------------------------
Public Function GetLast&(s$, char$)
Dim i&
On Error Resume Next
For i = Len(s) To 1 Step -1
    If Mid$(s, i, 1) = char Then
        GetLast = i: Exit Function
    End If
Next
End Function

'------------------------------------
'returns all text to right of last '\', else all text
'------------------------------------
Public Function ExtractName$(ByVal fil$)
Dim r&, s$
On Error Resume Next
    r = GetLast(fil, "\")
    If r = 0 Then
        ExtractName = fil
    Else
        ExtractName = Mid$(fil, r + 1)
    End If
End Function

'------------------------------------
'assumes a filename, trims last "\"
'------------------------------------
Public Function ExtractPath$(ByVal fil$)
Dim r&, s$
On Error Resume Next
    r = GetLast(fil, "\")
    If r = 0 Then
        ExtractPath = fil
    Else
        ExtractPath = Left$(fil, r - 1)
    End If
End Function

'---------------------------------------------------------
' Functions to aid in reading in binary data from file
'---------------------------------------------------------
Public Function ReadByte(ptr&, Value As Byte) As Boolean
    CopyToByteFromPtr Value, ptr, 1
    ptr = ptr + 1
    ReadByte = True
End Function

Public Function ReadShort(ptr&, Value%) As Boolean
    CopyToIntegerFromPtr Value, ptr, 2
    ptr = ptr + 2
    ReadShort = True
End Function

Public Function ReadLong(ptr&, Value&) As Boolean
    CopyToLongFromPtr Value, ptr, 4
    ptr = ptr + 4
    ReadLong = True
End Function

Public Function ReadFloat(ptr&, Value!) As Boolean
    CopyToSingleFromPtr Value, ptr, 4
    ptr = ptr + 4
    ReadFloat = True
End Function

Public Function Read3Floats(ptr&, v3!()) As Boolean
    CopyToSingleFromPtr v3(0), ptr, 12
    ptr = ptr + 12
    Read3Floats = True
End Function

Public Function ReadDouble(ptr&, Value#) As Boolean
    CopyToDoubleFromPtr Value, ptr, 8
    ptr = ptr + 8
    ReadDouble = True
End Function

'------------------------------------------------------------
'the following 2 functions are used by the obj file reader
'------------------------------------------------------------
Public Function GetNextToken(token$, lin$, pos&) As Boolean
Dim PtrStart&, char&
On Error GoTo ErrorHandler
'
'find start of token
Do While pos <= Len(lin)
    char = Asc(Mid$(lin, pos&, 1))
    If char = 13 Or char = 10 Then
        Debug.Assert 0
        Exit Function
    ElseIf char = 35 Then '# comments
        Debug.Assert 0
        Exit Function
    ElseIf char = 34 Then '" string
        Debug.Assert 0
        Exit Function
    ElseIf char = 44 Then ', comma
        'white space, continue
    ElseIf char > 32 And char < 127 Then
        Exit Do
    End If
    pos = pos + 1
Loop
PtrStart = pos
'
'find the end of the current token
Do While pos <= Len(lin)
    char = Asc(Mid$(lin, pos, 1))
    If char < 33 Or char > 126 Then Exit Do
    If char = 35 Then 'comment #
        'knight.obj is corrupted
        'Exit Do
    ElseIf char = 40 Or char = 41 Then '() brackets
        Debug.Assert 0
        Exit Do
    ElseIf char = 44 Then ', comma
        Debug.Assert 0
        Exit Do
    End If
    pos = pos + 1
Loop
'
'pos now points to first white space or char after this token
token = Mid$(lin, PtrStart, pos - PtrStart)
If token = "" Then Debug.Assert 0
'Debug.Print token
GetNextToken = -1
Exit Function
'
'------------------------------------------------------------
ErrorHandler:
Debug.Print Err.Description
Debug.Assert 0
Exit Function
Resume Next
End Function

'------------------------------------------------------------
Public Function GetFaceIndices(v&(), t&(), n&(), lin$) As Long
Dim cnt&, char&, pos&, lastpos&
Dim token$, linpos&, i&
On Error GoTo ErrorHandler
'
linpos = 3
If Not GetNextToken(token, lin, linpos) Then GoTo ErrorHandler
cnt = NumSlashes(token)
If Not InStr(token, "//") Then
    cnt = cnt + 1
End If
Do
    ' can be one of %d, %d/%d, %d//%d, %d/%d/%d
    Select Case cnt
    Case 0
        v(i) = Val(token)
    Case 1
        pos = InStr(token, "/")
        v(i) = Val(Left$(token, pos - 1))
        t(i) = Val(Mid$(token, pos + 1))
    Case 2
        lastpos = InStr(token, "/")
        v(i) = Val(Left$(token, lastpos - 1))
        n(i) = Val(Mid$(token, pos + 2))
    Case 3
        lastpos = InStr(token, "/")
        v(i) = Val(Left$(token, lastpos - 1))
        pos = InStr(lastpos + 1, token, "/")
        t(i) = Val(Mid$(token, lastpos + 1, pos - lastpos - 1))
        n(i) = Val(Mid$(token, pos + 1))
    End Select
    i = i + 1
    If i = 3 Then Exit Do
    If Not GetNextToken(token, lin, linpos) Then GoTo ErrorHandler
Loop
'return number of values read
GetFaceIndices = cnt
Exit Function
'
'------------------------------------------------------------
ErrorHandler:
Debug.Assert 0
GetFaceIndices = -1
Exit Function
Resume Next
End Function

'------------------------------------------------------------
Public Function NumSlashes&(s$)
Dim i&, cnt&
    For i = 1 To Len(s)
        If Mid$(s, i, 1) = "/" Then cnt = cnt + 1
    Next
    NumSlashes = cnt
End Function