OBJ+MTL exporter

25Mar07

This macro exports parts and (simple) assemblies to Alias OBJ format, generating a corresponding MTL material file at the same time.

This will evolve towards an exporter to Hyperion soon …

'OBJ+MTL exporter : exports parts and (simple) assemblies to Alias OBJ format,
'generating a corresponding MTL material file at the same time.
'Author : Ph. Guglielmetti, (www.goulu.net) Switzerland, all rights reserved
'Licence: you may use this macro for free, as long as this header is kept untouched.
'License: no support is provided
'Licence: it is forbidden to sell this code or publish it elsewhere without our permission
'Note : "Microsoft Scripting Runtime" must be added to support "Dictionary" data type
'Revision : PGu 2007/03/25 first step towards a Hyperion exporter (http://www.hypergraphics3d.com/)

Const mm As Double = 0.001
Const scal = 1 / mm ' factor the scale the export

Public swApp As SldWorks.SldWorks

Private materials As New dictionary
Private offset As Long ' to append meshes in same OBJ file

Sub main()
    Set swApp = Application.SldWorks
    Dim doc As SldWorks.ModelDoc2
    Set doc = swApp.ActiveDoc
    Open doc.GetPathName + ".obj" For Output As 1
    Print #1, "# SolidWorks to OBJ exporter by Dr. Goulu"
    Dim mtlfile As String: mtlfile = doc.GetPathName + ".mtl"
    mtlfile = Mid(mtlfile, InStrRev(mtlfile, "\") + 1) ' remove path
    Print #1, "mtllib "; Replace(mtlfile, " ", "")
    offset = 1 'vertices are numbered from 1 in OBJ format
    Select Case doc.GetType
        Case swDocPART:
            Call AddMaterial(doc.MaterialUserName, doc.MaterialPropertyValues)
            Call ExportOBJ(doc.GetBodies2(swSolidBody, True), doc.MaterialUserName)
        Case swDocASSEMBLY:
            Call Traverse(doc.GetActiveConfiguration.GetRootComponent)
    End Select
    Close 1
    Call ExportMTL(mtlfile)
End Sub

Private Sub Traverse(comp As SldWorks.Component2)
    Dim mat As String: mat = comp.GetMaterialUserName
    If Not AddMaterial(mat, comp.GetMaterialPropertyValues2(swThisConfiguration, Nothing)) Then
        On Error Resume Next ' dirty way to skip assemblies
        mat = comp.GetModelDoc.MaterialUserName
        Call AddMaterial(mat, comp.GetModelDoc.MaterialPropertyValues)
        On Error GoTo 0
    End If
    Call ExportOBJ(comp.GetBodies2(swSolidBody), mat, comp.Transform2)
    Dim children As Variant: children = comp.GetChildren
    Dim c As Variant
    For Each c In children
        Dim child As Component2: Set child = c
        Call Traverse(child) 'recurse in parts
    Next c
End Sub

Private Sub ExportOBJ(bodies As Variant, material As String, Optional transform As SldWorks.MathTransform)
    If IsEmpty(bodies) Then Exit Sub
    Dim b As Variant
    For Each b In bodies
        Dim body As SldWorks.Body2: Set body = b

        Print #1, "": Print #1, "#Body "; body.name
        Print #1, "g"
        Dim mat As String: mat = body.GetMaterialUserName2
        If mat <> "" Then
            Call AddMaterial(body.GetMaterialUserName2, body.MaterialPropertyValues2)
        Else
            mat = material 'default material
        End If
        If mat <> "" Then Print #1, "usemtl "; material
        Dim tess As SldWorks.Tessellation
        Dim e As Variant 'empty
        Set tess = body.GetTessellation(e)
        tess.NeedFaceFacetMap = True
        tess.MatchType = swTesselationMatchFacetTopology
        Debug.Assert tess.Tessellate
        Dim n As Long: n = tess.GetVertexCount
        Dim i As Long
        For i = 0 To n - 1
            Dim xyz As Variant
            If Not transform Is Nothing Then
                Dim v As SldWorks.MathPoint
                Set v = swApp.GetMathUtility.CreatePoint(tess.GetVertexPoint(i))
                Set v = v.MultiplyTransform(transform)
                xyz = v.ArrayData
            Else
                xyz = tess.GetVertexPoint(i)
            End If
            Const fmt = "0.000000"
            Print #1, "v "; Format(xyz(0) * scal, fmt); " "; Format(xyz(1) * scal, fmt); " "; Format(xyz(2) * scal, fmt)
        Next i
        Dim f As SldWorks.Face2
        Set f = body.GetFirstFace
        n = 0
        While Not f Is Nothing
            n = n + 1
            Print #1, "g "; body.name; " "; f.GetFeature.name; " face"; n
            Dim facets As Variant: facets = tess.GetFaceFacets(f)
            For i = LBound(facets) To UBound(facets)
                Dim fins As Variant: fins = tess.GetFacetFins(facets(i))
                Debug.Assert (UBound(fins)) = 2 ' make sure we have only triangles
                Dim pts(2) As Long ': ReDim pts(UBound(fins))
                Dim j As Long
                For j = LBound(fins) To UBound(fins)
                    Dim vert As Variant: vert = tess.GetFinVertices(fins(j))
                    pts(j) = vert(0)
                Next j
                Print #1, "f "; pts(0) + offset; pts(1) + offset; pts(2) + offset
            Next i
            Set f = f.GetNextFace
        Wend
        offset = offset + tess.GetVertexCount
    Next b
End Sub

Private Function AddMaterial(name As String, properties As Variant) As Boolean
    If name = "" Then Exit Function
    If Not materials.Exists(name) Then
        Call materials.Add(name, properties)
        AddMaterial = True
    End If
End Function

Private Sub ExportMTL(mtlfile As String)
    Open mtlfile For Output As 1
    Dim mat As Variant
    For Each mat In materials
        Print #1, "newmtl "; mat
        Dim p As Variant: p = materials(mat) '[ R, G, B, Ambient, Diffuse, Specular, Shininess, Transparency, Emission ]
        Dim r As Double: r = p(0)
        Dim g As Double: g = p(1)
        Dim b As Double: b = p(2)
        Print #1, "Ka "; r * p(3); g * p(3); b * p(3) 'Ambient
        Print #1, "Kd "; r * p(4); g * p(4); b * p(4) 'Diffuse
        Print #1, "Ks "; r * p(5); g * p(5); b * p(5) 'Specular
        'shininess ?
        Print #1, "Tf "; r * p(7); g * p(7); b * p(7)
        'emission ?
    Next mat
    Close 1
End Sub

Filed under: VBA, assembly, export, macro, part   |  Leave a Comment