Attribute VB_Name = "modSWtoOBJ"
Option Explicit

Dim swApp As SldWorks.SldWorks
Dim MathUtil As MathUtility
Dim Model As Object

Type DoubleRec
    dValue As Single
End Type

Type Int2Rec
    iLower As Long ' assuming that a C int has 4 bytes
End Type

Type MeshVertices
    Position As Variant
    Normal As Variant
    UV As Variant
End Type

Type MeshMaterial
    Material As String
    Indexes As Variant
    Indexes2 As Variant
    Vertices() As MeshVertices
End Type

Dim intMeshNumber As Integer
Dim varD() As MeshVertices
Dim lngPrevVert As Long
Dim varMaterial() As MeshMaterial
Dim varFins() As Long
Dim varCoFins() As Long
Dim strFileName As String
Dim varBaseMat As String
Dim boolPartConverting As Boolean
Dim boolComponentColor As Boolean
Dim boolSurfaceProcessing As Boolean

' Get the current model and traverse all its components
Public Sub SWtoOBJ()
 Dim swApp As Object
 Dim Configuration As SldWorks.Configuration
 Dim RootComponent As SldWorks.Component2

 Set swApp = CreateObject("SldWorks.Application")

 Set MathUtil = swApp.GetMathUtility

 ' Current document
 Set Model = swApp.ActiveDoc
    strFileName = getOutputFile(Model.GetPathName)

    intMeshNumber = 0
    lngPrevVert = 0
    boolComponentColor = False
    ReDim varMaterial(0)
    ReDim varD(0)
    ReDim varFins(0)

    'Open strFileName & ".log" For Output As #3

Select Case Model.GetType
     Case 1
         boolPartConverting = True
         getTesselation Model, Model.GetTitle
         If intMeshNumber > 0 Then writeObjFile
     Case 2
 ' Find the Root Component
        Set Configuration = Model.GetActiveConfiguration()
        Set RootComponent = Configuration.GetRootComponent()

 ' Recursively traverse the component
         If Not RootComponent Is Nothing Then
            boolPartConverting = False
            TraverseComponent 1, RootComponent
            If intMeshNumber > 0 Then writeObjFile
         End If
     Case Else
        MsgBox "Open Part and Assembly", vbExclamation + vbOKOnly
End Select
'Close #3
End Sub

' Recursive routine to traverse all the children of a component
Private Function TraverseComponent(Level As Integer, Component As SldWorks.Component2)
 Dim i As Integer
 Dim Children As Variant
 Dim Child As Object
 Dim ChildCount As Integer
 Dim ComponentState As Long

 ' Traverse the children
 Children = Component.GetChildren ' Get the list of children

 ' Get the # of elements in the variant safearray. UBound returns the upper element number. Since the array begins at zero, we must add 1 to get the actual number of array elements. If no elements are in the array, then UBound returns -1.
 ChildCount = UBound(Children) + 1

 ' Perform component specific operations...
 If Level > 1 Then

    ComponentState = Component.GetSuppression
    If ComponentState = 1 Then
        MsgBox "Please set all components state to Resolved", vbExclamation + vbOKOnly
        Close #1
        End
    ElseIf ComponentState = 2 And Component.IsHidden(False) = False Then
        If ChildCount = 0 Then
            boolComponentColor = False
            'Print #3, Component.name & vbCrLf
            getTesselation Component, Component.name, Component.GetXform
        End If
    End If

End If

 ' For each Child in this subassembly
For i = 0 To (ChildCount - 1)
' Get Child component object
Set Child = Children(i)
' Traverse the child's components
TraverseComponent Level + 1, Child
Next i

End Function

Function getOutputFile(strPath As String, Optional strChar As String = ".") As String
Dim i As Integer, intNext As Integer
   i = 1
    Do
      intNext = i
      i = InStr(i + 1, strPath, strChar)
    Loop While i > 0
    getOutputFile = Left(strPath, intNext - 1)
End Function

Function getFileName(strPath As String) As String
Dim i As Integer, intNext As Integer
   i = 1
    Do
      intNext = i
      i = InStr(i + 1, strPath, "\")
    Loop While i > 0
    getFileName = Right(strPath, Len(strPath) - intNext)
End Function

' Extract two integer values out of a single double value,
' by assigning a DoubleRec to the double value then
' copying the value over an Int2Rec and
' extracting the integer values.
Function ExtractFields(dValue As Single, iLower As Integer) ', iUpper As Integer)
Dim dR As DoubleRec, i2r As Int2Rec
    ' Set the double value
    dR.dValue = dValue
    ' Copy the values
    LSet i2r = dR
    ' Extract the values
    iLower = i2r.iLower
    'iUpper = i2r.iUpper
End Function

Private Function getTesselation(sldModel As Object, strModelName As String, Optional varComponentXForm = 0)
Dim i As Long
Dim sldPartDoc As SldWorks.ModelDoc2
Dim sldBody As SldWorks.body2
Dim SurfBodyList As Variant

boolSurfaceProcessing = False

If boolPartConverting = False Then
    Set sldBody = sldModel.GetBody 'Processing body of the component (includes assembly-level features)
    Set sldPartDoc = sldModel.GetModelDoc 'To process surfaces we should get PartDoc from assembly
Else
    Set sldBody = sldModel.Body 'Processing Part body
    Set sldPartDoc = sldModel
End If

varBaseMat = getBaseMaterial(sldModel)
If Not TypeName(sldBody) = "Nothing" Then
    intMeshNumber = intMeshNumber + 1
    ProcessBodyTesselation sldBody, varComponentXForm
End If

'Processing all Reference Surfaces
SurfBodyList = sldPartDoc.GetRelatedBodies
If Not TypeName(SurfBodyList) = "Empty" Then
    boolSurfaceProcessing = True
    For i = 0 To UBound(SurfBodyList)
        Set sldBody = SurfBodyList(i)
        intMeshNumber = intMeshNumber + 1
        ProcessBodyTesselation sldBody, varComponentXForm
    Next i
End If

End Function

Private Function ProcessBodyTesselation(sldBody As SldWorks.body2, varComponentXForm)
Dim sldTesselation As SldWorks.Tessellation
Dim lngFinsNum As Long, lngVertNum As Long
Dim lngCurVert As Long
Dim MathTrans As MathTransform
Dim MathP As MathPoint
Dim mathV As MathVector
Dim Coordinates3D As Variant
Dim sldFace As SldWorks.face2

Set sldTesselation = sldBody.GetTessellation(Empty)
sldTesselation.NeedVertexNormal = True
sldTesselation.NeedVertexParams = True
sldTesselation.NeedFaceFacetMap = True
sldTesselation.NeedEdgeFinMap = True
sldTesselation.NeedErrorList = False

sldTesselation.Tessellate

lngVertNum = sldTesselation.GetVertexCount

If intMeshNumber = 1 Then
    lngPrevVert = 0
End If

ReDim Preserve varD(lngVertNum + lngPrevVert)
ReDim varCoFins(0)

For lngCurVert = 0 To lngVertNum - 1
    Set MathP = MathUtil.CreatePoint(sldTesselation.GetVertexPoint(lngCurVert))
    If boolPartConverting = False Then
        Set MathTrans = MathUtil.CreateTransform(varComponentXForm)
        Set MathP = MathP.MultiplyTransform(MathTrans)
    End If
    Coordinates3D = MathP.ArrayData
    varD(lngCurVert + lngPrevVert + 1).Position = Array(Coordinates3D(0), Coordinates3D(1), Coordinates3D(2))
Next lngCurVert

For lngCurVert = 0 To lngVertNum - 1
    Set mathV = MathUtil.CreateVector(sldTesselation.GetVertexNormal(lngCurVert))
    If boolPartConverting = False Then
        Set mathV = mathV.MultiplyTransform(MathTrans)
    End If
    Coordinates3D = mathV.ArrayData
    varD(lngCurVert + lngPrevVert + 1).Normal = Array(Coordinates3D(0), Coordinates3D(1), Coordinates3D(2))
Next lngCurVert

For lngCurVert = 0 To lngVertNum - 1
    Coordinates3D = sldTesselation.GetVertexParams(lngCurVert)
    varD(lngCurVert + lngPrevVert + 1).UV = Array(Coordinates3D(0), Coordinates3D(1))
Next lngCurVert

Set sldFace = sldBody.GetFirstFace
' Traverse thru all body faces
Do While Not sldFace Is Nothing
    ProcessFaceTesselation sldTesselation, sldFace, boolComponentColor
    Set sldFace = sldFace.GetNextFace
Loop

lngPrevVert = lngPrevVert + lngCurVert

End Function

Private Function ProcessFaceTesselation(sldTesselation As SldWorks.Tessellation, sldFace As SldWorks.face2, boolComponentColor As Boolean)
Dim i As Long
Dim varFacetsInFace As Variant
Dim varCurVertexInFin As Variant
Dim varCurMat As String
Dim intCurFaceMaterial As Integer
Dim lngCurFacetInFace As Long, lngCurFacet As Long, lngCurFin As Long
Dim varFinsInFacet As Variant
Dim lngVerticesInFacet() As Long
Dim sldEdge As SldWorks.Edge
Dim varVertex As Variant
Dim boolWasInList As Boolean

boolWasInList = False
varFacetsInFace = sldTesselation.GetFaceFacets(sldFace)
If Not IsEmpty(varFacetsInFace) Then

    If boolComponentColor = True Then
        varCurMat = varBaseMat
    Else
        varCurMat = getFaceMaterial(sldFace)
        If Len(varCurMat) = 0 Then
            varCurMat = varBaseMat
        End If
    End If
    intCurFaceMaterial = findMatNum(varCurMat)

    'sldFace.Select (True)

    For lngCurFacetInFace = 0 To UBound(varFacetsInFace) ' - 1
        lngCurFacet = varFacetsInFace(lngCurFacetInFace)

        varFinsInFacet = sldTesselation.GetFacetFins(lngCurFacet)
        ReDim lngVerticesInFacet(0)
        Set sldEdge = Nothing
         For lngCurFin = 0 To UBound(varFinsInFacet) ' - 1
           varCurVertexInFin = sldTesselation.GetFinVertices(varFinsInFacet(lngCurFin))
           Set sldEdge = sldTesselation.GetFinEdge(varFinsInFacet(lngCurFin))

           If Not TypeName(sldEdge) = "Nothing" Then
            If findInArray(varCoFins, varFinsInFacet(lngCurFin)) = False Then

                ReDim Preserve varFins(UBound(varFins) + 1)
                varFins(UBound(varFins)) = lngPrevVert + varCurVertexInFin(0) + 1
                ReDim Preserve varFins(UBound(varFins) + 1)
                varFins(UBound(varFins)) = lngPrevVert + varCurVertexInFin(1) + 1

                ReDim Preserve varCoFins(UBound(varCoFins) + 1)
                varCoFins(UBound(varCoFins)) = sldTesselation.GetFinCoFin(varFinsInFacet(lngCurFin))
             End If
           End If

             For i = 0 To 1
                For Each varVertex In lngVerticesInFacet
                  If varCurVertexInFin(i) = varVertex Then
                    boolWasInList = True
                    Exit For
                  End If
                Next varVertex
                If boolWasInList = False Then
                 If lngCurFin = 0 And i = 0 Then
                    ReDim Preserve lngVerticesInFacet(UBound(lngVerticesInFacet))
                 Else
                    ReDim Preserve lngVerticesInFacet(UBound(lngVerticesInFacet) + 1)
                 End If
                lngVerticesInFacet(UBound(lngVerticesInFacet)) = varCurVertexInFin(i)
                End If
                boolWasInList = False
            Next i
         Next lngCurFin
         'Workaround the problem with Z-flipping models
         'For i = UBound(lngVerticesInFacet) To 0 Step -1
         For i = 0 To UBound(lngVerticesInFacet)
            addToArray varMaterial(intCurFaceMaterial).Indexes, lngPrevVert + lngVerticesInFacet(i) + 1
         Next i
    Next lngCurFacetInFace

End If
End Function




Private Function writeObjFile()
 Dim i As Long, n As Long, prevN As Long
 Dim YIndex As Variant, varMeshMaterial As Variant
 Dim dR As Double, dG As Double, dB As Double
 Dim curMatName As String, strName As String

Open strFileName & ".obj" For Output As #1
Open strFileName & ".mtl" For Output As #2

            Dim strFil As String
            strFil = getFileName(strFileName)
            strName = strFil
           
            Print #1, "# num_vertices:"; UBound(varD)
            Print #1,
            Print #2, "# num_materials:"; UBound(varMaterial)
            Print #2,
            For i = 1 To UBound(varMaterial)
                Print #2, "newmtl"; i
                varMeshMaterial = Split(varMaterial(i).Material, vbNullChar)
                dR = varMeshMaterial(0)
                dG = varMeshMaterial(1)
                dB = varMeshMaterial(2)
                Print #2, "Ka "; dR * varMeshMaterial(3); " "; dG * varMeshMaterial(3); " "; dB * varMeshMaterial(3)
                Print #2, "Kd "; dR * varMeshMaterial(4); " "; dG * varMeshMaterial(4); " "; dB * varMeshMaterial(4)
                Print #2, "Ks "; dR * varMeshMaterial(5); " "; dG * varMeshMaterial(5); " "; dB * varMeshMaterial(5)
                'Print #2, "Ke "; dR * varMeshMaterial(8); " "; dG * varMeshMaterial(8); " "; dB * varMeshMaterial(8)
                Print #2, "d "; 1 - varMeshMaterial(7)
                Print #2, "Tr "; 1 - varMeshMaterial(7)
                Print #2, "illum 2" '; varMeshMaterial(8)
                Print #2, "Ns "; 1 - varMeshMaterial(6)
                Print #2,
            Next i
                Print #2, "newmtl"; i
                dR = 0
                dG = 0
                dB = 0
                Print #2, "Ka "; dR; " "; dG; " "; dB
                Print #2, "Kd "; dR; " "; dG; " "; dB
                Print #2, "Ks "; dR; " "; dG; " "; dB
                Print #2, "d 1"
                Print #2, "Tr 1"
                Print #2, "illum 1" '; varMeshMaterial(8)
                Print #2, "Ns 0"
                Print #2,

            Print #1, "mtllib "; getFileName(strFileName); ".mtl"
            Print #1,
            
            For i = 1 To UBound(varD())
                Print #1, "v " & varD(i).Position(0) & " " & varD(i).Position(1) & " " & varD(i).Position(2)
            Next i

            Print #1, "# num_vertices:"; i
            Print #1,

            For i = 1 To UBound(varD())
                Print #1, "vn " & varD(i).Normal(0) & " " & varD(i).Normal(1) & " " & varD(i).Normal(2)
            Next i

            Print #1, "# num_vertex_normals:"; i
            Print #1,

            For i = 1 To UBound(varD())
                Print #1, "vt " & varD(i).UV(0) & " " & varD(i).UV(1)
            Next i

            Print #1, "# num_uvs:"; i
            Print #1,

        For i = 1 To UBound(varMaterial)
        
            Print #1,
            Print #1, "g "; strName & i
            Print #1,
        
            Print #1, "usemtl "; i
            varMeshMaterial = varMaterial(i).Indexes
                For n = 1 To UBound(varMeshMaterial) Step 3
                    Print #1, "f " & varMeshMaterial(n) & "/" & varMeshMaterial(n) & "/" & varMeshMaterial(n) & " " & varMeshMaterial(n + 1) & "/" & varMeshMaterial(n + 1) & "/" & varMeshMaterial(n + 1) & " " & varMeshMaterial(n + 2) & "/" & varMeshMaterial(n + 2) & "/" & varMeshMaterial(n + 2)
                Next n
        Next i



'Close #3
Close #2
Close #1
End Function

Private Function getBaseMaterial(sldModel As Object) As String
getBaseMaterial = convArrayToStr(sldModel.MaterialPropertyValues)

    Dim strPWmat As String
    If boolPartConverting = False Then strPWmat = sldModel.GetMaterialUserName Else strPWmat = sldModel.MaterialUserName
    If Len(strPWmat) > 0 Then getBaseMaterial = getBaseMaterial & vbNullChar & strPWmat

    If Len(getBaseMaterial) = 0 Then
        Dim sldPart As Object
        Set sldPart = sldModel.GetModelDoc
        getBaseMaterial = convArrayToStr(sldPart.MaterialPropertyValues)
        strPWmat = sldPart.MaterialUserName
        If Len(strPWmat) > 0 Then getBaseMaterial = getBaseMaterial & vbNullChar & strPWmat
    ElseIf boolPartConverting = False Then
        boolComponentColor = True
    End If
End Function

Private Function getFaceMaterial(sldFace As Object) As String
getFaceMaterial = convArrayToStr(sldFace.MaterialPropertyValues)

Dim strPWmat As String
strPWmat = sldFace.MaterialUserName
If Len(strPWmat) > 0 Then getFaceMaterial = getFaceMaterial & vbNullChar & strPWmat

    If Len(getFaceMaterial) = 0 Then
        Dim sldFeature As SldWorks.Feature
        Set sldFeature = sldFace.GetFeature
        If Not TypeName(sldFeature) = "Nothing" Then
            getFaceMaterial = convArrayToStr(sldFeature.GetMaterialPropertyValues)

            strPWmat = sldFeature.GetMaterialUserName
            If Len(strPWmat) > 0 Then getFaceMaterial = getFaceMaterial & vbNullChar & strPWmat

            If Len(getFaceMaterial) = 0 Then
                Dim strFeatureType As String
                strFeatureType = sldFeature.GetTypeName

                If strFeatureType = "MirrorPattern" Or strFeatureType = "LPattern" Or strFeatureType = "CirPattern" Then
                    Dim sldPatternFeatureData As Variant
                    Set sldPatternFeatureData = sldFeature.GetDefinition
                    Dim ParFeaturesList As Variant
                    ParFeaturesList = sldPatternFeatureData.PatternFeatureArray
                    If UBound(ParFeaturesList) = 0 Then
                        getFaceMaterial = convArrayToStr(ParFeaturesList(0).GetMaterialPropertyValues)

                        strPWmat = ParFeaturesList(0).GetMaterialUserName
                        If Len(strPWmat) > 0 Then getFaceMaterial = getFaceMaterial & vbNullChar & strPWmat

                    End If
                End If
            End If
        End If
    End If
End Function

Private Function convArrayToStr(varArray) As String
If Not IsEmpty(varArray) Then
Dim i As Integer
    For i = 0 To UBound(varArray)
        convArrayToStr = convArrayToStr & varArray(i) & vbNullChar
    Next i
    convArrayToStr = Trim(convArrayToStr)
End If
End Function

Private Function findMatNum(varMat As String) As Integer
Dim intWas As Integer
Dim i As Integer, n As Integer, v As Integer
Dim curExistMat As String

    If boolSurfaceProcessing = True Then
        Dim strMatLeft As String
        strMatLeft = getOutputFile(varMat, vbNullChar)
        varMat = strMatLeft & vbNullChar & "doublesided" & Right(varMat, Len(varMat) - Len(strMatLeft))
    End If
    For findMatNum = 1 To UBound(varMaterial)
        If varMat = varMaterial(findMatNum).Material Then
         Exit Function
        End If
    Next findMatNum

    ReDim Preserve varMaterial(UBound(varMaterial) + 1)
    varMaterial(UBound(varMaterial)).Material = varMat

End Function

Function findInArray(varArray, varFindElement) As Boolean
Dim n As Long
findInArray = False
    For n = 1 To UBound(varArray)
        If varFindElement = varArray(n) Then
            findInArray = True
            Exit For
        End If
    Next n
End Function

Function addToArray(varArray, varData)
If IsEmpty(varArray) Then
    ReDim varArray(1)
Else
    ReDim Preserve varArray(UBound(varArray) + 1)
End If
    varArray(UBound(varArray)) = varData
End Function

Public Function HeapSort(Keys)
   Dim Base As Long: Base = LBound(Keys)                    ' array index base
   Dim n As Long: n = UBound(Keys) - LBound(Keys) + 1        ' array size
   ReDim Index(Base To Base + n - 1) As Long                ' allocate index array
   Dim i As Long, m As Long
   For i = 0 To n - 1: Index(Base + i) = Base + i: Next     ' fill index array
   For i = n \ 2 - 1 To 0 Step -1                           ' generate ordered heap
      Heapify Keys, Index, i, n
      Next
   For m = n To 2 Step -1
      Exchange Index, 0, m - 1                              ' move highest element to top
      Heapify Keys, Index, 0, m - 1
      Next
   HeapSort = Index
End Function

Private Sub Heapify(Keys, Index() As Long, ByVal i1 As Long, ByVal n As Long)
   ' Heap order rule: a[i] >= a[2*i+1] and a[i] >= a[2*i+2]
   Dim Base As Long: Base = LBound(Index)
   Dim nDiv2 As Long: nDiv2 = n \ 2
   Dim i As Long: i = i1
   Do While i < nDiv2
      Dim k As Long: k = 2 * i + 1
      If k + 1 < n Then
         If Keys(Index(Base + k)) < Keys(Index(Base + k + 1)) Then k = k + 1
         End If
      If Keys(Index(Base + i)) >= Keys(Index(Base + k)) Then Exit Do
      Exchange Index, i, k
      i = k
      Loop
End Sub

Private Sub Exchange(a() As Long, ByVal i As Long, ByVal j As Long)
   Dim Base As Long: Base = LBound(a)
   Dim Temp As Long: Temp = a(Base + i)
   a(Base + i) = a(Base + j)
   a(Base + j) = Temp
End Sub