AnsweredAssumed Answered

Get macro to save as part and combine solids

Question asked by Thijs Vernooij on Jan 12, 2018
Latest reply on Jan 16, 2018 by Matt Bieringer

Hi guys,

 

I've created a macro to save an assembly as a part, open that part, and combine all solids.

 

It's running okay, but the point is that when i run the macro starting from an assembly, the macro creates the part, opens that created part, but then stops running.

I have to click again on the same macro, and then it's creating the combine of all the solids.

 

When I edit the macro, and run it step by step (F8), it will run continiously.

 

I need to run the macro continiously from the assembly, so I can create STL files automatically.

 

Thanks for your help,

 

Thijs

-------

     

Option Explicit

 

 

Sub SaveAndOpen(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2)

 

 

 

 

Dim SwDoc As ModelDoc2

'Dim swApp As Object

 

 

Dim sldwrks As SldWorks.SldWorks

Dim Part As ModelDoc2

Dim boolstatus As Boolean

Dim longstatus As Long, longwarnings As Long

Dim swRootComp As SldWorks.Component2

Dim sPadStr As String

Dim vBody As Variant

 

 

Set sldwrks = _

Application.SldWorks

 

 

Set Part = sldwrks.ActiveDoc

 

 

Dim newfileName As String

newfileName = Part.GetPathName

 

 

newfileName = Replace(newfileName, ".sldasm", ".sldprt")

newfileName = Replace(newfileName, ".SLDASM", ".SLDPRT")

 

 

Debug.Print newfileName;

 

 

longstatus = Part.SaveAs3(newfileName, 0, 0)

 

 

Set swApp = _

Application.SldWorks

Set Part = swApp.ActiveDoc

Set Part = swApp.OpenDoc6(newfileName, 1, 0, "", longstatus, longwarnings)

'Set Part = swApp.OpenDoc6("L:\Moogue\DriveWorks\DW-Orders\WebShopBestelling\1187-2455-BHSHUVZVL__-Marjolein Smids_TextSleutelhanger-SLT001_ ID109\1187-2455_2325_-TextSleutelhanger-SLT001----L_Johnny_-R_UwspaceText_-Oranje-_ ID109.SLDPRT", 1, 0, "", longstatus, longwarnings)

 

 

 

 

'Set Part = Nothing

'Set sldwrks = Nothing

 

 

SelectBodies swApp, swModel, vBody, sPadStr

 

 

End Sub

 

 

Sub SelectBodies(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, vBody As Variant, sPadStr As String)

 

 

    Dim swModExt As SldWorks.ModelDocExtension

    Dim swBody As SldWorks.Body2

    Dim sBodySelStr As String

    Dim sBodyTypeSelStr As String

    Dim i As Long

    Dim bRet As Boolean

    Dim swCombineBodiesFeatureData As SldWorks.CombineBodiesFeatureData

    Dim swFeature As SldWorks.Feature

    Dim status As Boolean

    Dim errors As Long

    Dim warnings As Long

    Dim newfileName As String

 

 

   

Dim Part As Object

Dim boolstatus As Boolean

Dim longstatus As Long, longwarnings As Long

'Dim myFeature As Object

'Su main()

Dim myFeature As Object

Set swApp = _

Application.SldWorks

 

 

Set Part = swApp.ActiveDoc

'Set Part = swApp.OpenDoc6(newfileName, 1, 0, "", longstatus, longwarnings)

   

 

 

 

    'If IsEmpty(vBody) Then Set myFeature = Part.FeatureManager.InsertCombineFeature(swBodyOperationType_e.SWBODYADD, Nothing, vBody)

    'If IsEmpty(vBody) Then Set myFeature = Part.FeatureManager.InsertCombineFeature(15903, Nothing, vBody)

    'If IsEmpty(vBody) Then Set myFeature = Part.FeatureManager.InsertDeleteBody2(True)

    

   

    If IsEmpty(vBody) Then Exit Sub

  

    Set swModExt = swModel.Extension

 

 

    For i = 0 To UBound(vBody)

        Set swBody = vBody(i)

        sBodySelStr = swBody.GetSelectionId

        Debug.Print "  " & sPadStr & sBodySelStr

 

 

        Select Case swBody.GetType

            Case swSolidBody

                sBodyTypeSelStr = "SOLIDBODY"

            Case swSheetBody

                sBodyTypeSelStr = "SURFACEBODY"

            Case Else

                Debug.Assert False

        End Select

       

      

        boolstatus = Part.Extension.SelectByID2(sBodySelStr, sBodyTypeSelStr, 0, 0, 0, True, 0, Nothing, 0)

      

        Set myFeature = Part.FeatureManager.InsertCombineFeature(15903, Nothing, vBody)

   

    Next i

 

 

End Sub

 

 

Sub ProcessComponent(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swComp As SldWorks.Component2, nLevel As Long)

 

 

    Dim vChildComp As Variant

    Dim swChildComp As SldWorks.Component2

    Dim sPadStr As String

    Dim vBody As Variant

    Dim i As Long

 

 

    For i = 0 To nLevel - 1

        sPadStr = sPadStr + "  "

    Next i

 

 

    Debug.Print sPadStr & swComp.Name2 & " <" & swComp.ReferencedConfiguration & ">"

 

 

    ' Solid bodies

    vBody = swComp.GetBodies2(swSolidBody)

    SelectBodies swApp, swModel, vBody, sPadStr

 

 

    ' Surface bodies

    vBody = swComp.GetBodies2(swSheetBody)

    SelectBodies swApp, swModel, vBody, sPadStr

 

 

    vChildComp = swComp.GetChildren

    For i = 0 To UBound(vChildComp)

        Set swChildComp = vChildComp(i)

        ProcessComponent swApp, swModel, swChildComp, nLevel + 1

    Next i

 

 

End Sub

 

 

Sub ProcessAssembly(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2)

 

 

    Dim swConfigMgr As SldWorks.ConfigurationManager

    Dim swConf As SldWorks.Configuration

    Dim swRootComp As SldWorks.Component2

 

 

    Set swConfigMgr = swModel.ConfigurationManager

    Set swConf = swConfigMgr.ActiveConfiguration

    Set swRootComp = swConf.GetRootComponent3(True)

    ProcessComponent swApp, swModel, swRootComp, 1

 

 

End Sub

 

 

Sub Combiner(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2)

 

 

Dim Part As Object

Dim boolstatus As Boolean

Dim longstatus As Long, longwarnings As Long

Dim myFeature As Object

Dim sldwrks As SldWorks.SldWorks

 

 

'Dim Part As ModelDoc2

'Dim boolstatus As Boolean

'Dim longstatus As Long, longwarnings As Long

'Dim swApp As SldWorks.SldWorks

'Dim swModel As SldWorks.ModelDoc2

 

 

Dim swModelDocExt As SldWorks.ModelDocExtension

Dim swFeatureMgr As SldWorks.FeatureManager

Dim swFeature As SldWorks.Feature

Dim swCombineBodiesFeatureData As SldWorks.CombineBodiesFeatureData

Dim fileName As String

Dim status As Boolean

Dim errors As Long

Dim warnings As Long

 

 

'Dim swApp As Object

'Dim Part As Object

'Dim boolstatus As Boolean

'Dim longstatus As Long, longwarnings As Long

   

'Dim myFeature As Object

 

 

    'Set swApp = Application.SldWorks

'    Set Part = sldwrks.ActiveDoc

 

 

    'fileName = "C:\Program Files\SolidWorks Corp\SolidWorks\samples\tutorial\multibody\multi_inter.sldprt"

    'Set swModel = swApp.OpenDoc6(fileName, swDocumentTypes_e.swDocPART, swOpenDocOptions_e.swOpenDocOptions_Silent, "", errors, warnings)

    'Set swModel = SldWorks.ActiveDoc

 

 

    'Set swModelDocExt = swModel.Extension

    'status = swModelDocExt.SelectByID2("Extrude-Thin1", "SOLIDBODY", 0, 0, 0, True, 0, Nothing, 0)

    'status = swModelDocExt.SelectByID2("Boss-Extrude1", "SOLIDBODY", 0, 0, 0, True, 0, Nothing, 0)

    'swModel.ClearSelection2 False

    'status = swModelDocExt.SelectByID2("Extrude-Thin1", "SOLIDBODY", 0, 0, 0, False, 2, Nothing, 0)

    'status = swModelDocExt.SelectByID2("Boss-Extrude1", "SOLIDBODY", 0, 0, 0, True, 2, Nothing, 0)

    'Set swFeatureMgr = swModel.FeatureManager

    'Set swFeature = swFeatureMgr.InsertCombineFeature(swBodyOperationType_e.SWBODYADD, Nothing, Nothing)

 

 

    'Set swCombineBodiesFeatureData = swFeature.GetDefinition

    'status = swCombineBodiesFeatureData.AccessSelections(swModel, Nothing)

    'swCombineBodiesOperationType_e:

    ' swCombineBodiesOperationAdd = 0

    ' swCombineBodiesOperationCommon = 2

    ' swCombineBodiesOperationSubract = 1

    'Debug.Print "Type of combine feature: " & swCombineBodiesFeatureData.OperationType

    'swCombineBodiesFeatureData.ReleaseSelectionAccess

 

 

'Set myFeature = Part.FeatureManager.InsertCombineFeature(15903, Nothing, Nothing)

   

'Set myFeature = Part.FeatureManager.InsertDeleteBody2(True)

 

 

End Sub

 

 

Sub main()

 

 

    Dim swApp As SldWorks.SldWorks

    Dim swModel As SldWorks.ModelDoc2

    Dim swPart As SldWorks.PartDoc

    Dim vBody As Variant

    Dim i As Long

    Dim bRet As Boolean

 

 

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc

 

 

    swModel.ClearSelection2 True

 

 

    Debug.Print "File = " & swModel.GetPathName

 

 

    Select Case swModel.GetType

        Case swDocPART

            Set swPart = swModel

            ' Solid bodies

            vBody = swPart.GetBodies2(swSolidBody, True)

            SelectBodies swApp, swModel, vBody, ""

            Combiner swApp, swModel

            ' Surface bodies

            vBody = swPart.GetBodies2(swSheetBody, True)

            SelectBodies swApp, swModel, vBody, ""

        Case swDocASSEMBLY

            'ProcessAssembly swApp, swModel

            SaveAndOpen swApp, swModel

        Case Else

            Exit Sub

 

 

    End Select

 

 

End Sub

 

-----

Attachments

Outcomes