Macro Sort Design Tree

Option Explicit

Sub Main()

    

    Dim swApp           As SldWorks.SldWorks

    Dim swModel         As SldWorks.ModelDoc2

    Dim swFeatureMgr    As SldWorks.FeatureManager

    Dim swAssy          As SldWorks.AssemblyDoc

    Dim swFeat          As SldWorks.Feature

    Dim swFolder        As SldWorks.FeatureFolder

    

    Dim I               As Integer

    Dim Y               As Integer

    Dim K               As Integer

    Dim FolderName      As String

    Dim vComp()         As Variant

    Dim vFeat           As Variant

    Dim Flag            As Boolean

    

    Dim Start           As Double

    Dim Fine            As Double

    

    Start = Timer

    

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc

    Set swFeatureMgr = swModel.FeatureManager

    Set swAssy = swModel

    

    If swModel.GetType <> 2 Then

        MsgBox "Aprire un assieme", vbCritical + vbOKOnly, "Errore"

        Exit Sub

    End If

    

    GraphicBoost swApp, swModel, False

    

    vFeat = swFeatureMgr.GetFeatures(True)

    Flag = True

    

    For I = 0 To UBound(vFeat)

        Set swFeat = vFeat(I)

        If Right(swFeat.Name, 12) = "___EndTag___" Then

            K = K - 1

        ElseIf swFeat.GetTypeName2 = "FtrFolder" Then

            K = K + 1

        End If

        If Flag = True Then

            If swFeat.GetTypeName2 = "Reference" Then

                ReDim Preserve vComp(0 To Y)

                Set vComp(Y) = swFeat.GetSpecificFeature2

                Y = Y + 1

            End If

            If swFeat.GetTypeName2 = "FtrFolder" Then

                CathFolderComp swFeat, swModel

                FolderName = "Cartella" & K & "___EndTag___"

                Flag = False

            End If

        End If

        If K = 0 Then

            Flag = True

        End If

    Next I

    

    If Y > 0 Then

        SortComp vComp, swModel, swFolder, True

    End If

    

    Fine = Timer - Start

    Debug.Print Fine

    

    GraphicBoost swApp, swModel, True

    

End Sub

Function CathFolderComp(swFeat As SldWorks.Feature, swModel As SldWorks.ModelDoc2)

    Dim swFolder       As SldWorks.FeatureFolder

    Dim swSubFeat      As SldWorks.Feature

    

    Dim vFeat          As Variant

    Dim vComp()        As Variant

    Dim X              As Integer

    Dim Y              As Integer

    

    Set swFolder = swFeat.GetSpecificFeature2

    

    vFeat = swFolder.GetFeatures

    

    For X = 0 To UBound(vFeat)

        Set swSubFeat = vFeat(X)

        If swSubFeat.GetTypeName2 = "Reference" Then

            ReDim Preserve vComp(0 To Y)

            Set vComp(Y) = swSubFeat.GetSpecificFeature2

            Y = Y + 1

        End If

        If swSubFeat.GetTypeName2 = "FtrFolder" Then

            CathFolderComp swSubFeat, swModel

        End If

    Next X

    

    SortComp vComp, swModel, swFolder, False

    

End Function

    

Function SortComp(vComp As Variant, swModel As SldWorks.ModelDoc2, swFolder As SldWorks.FeatureFolder, Flag As Boolean)

    

    Dim swAssy      As SldWorks.AssemblyDoc

    Dim swSelMgr    As SldWorks.SelectionMgr

    Dim swComp      As SldWorks.Component2

    

    Dim I           As Long

    Dim Y           As Long

    

    Set swSelMgr = swModel.SelectionManager

    Set swAssy = swModel

    

    For I = 0 To UBound(vComp) - 1

        For Y = I + 1 To UBound(vComp)

            If vComp(I).GetPathName = vComp(Y).GetPathName Then

                If CInt(Right(vComp(I).Name, Len(vComp(I).Name) - InStrRev(vComp(I).Name, "-"))) > CInt(Right(vComp(Y).Name, Len(vComp(Y).Name) - InStrRev(vComp(Y).Name, "-"))) Then

                    Set swComp = vComp(I)

                    Set vComp(I) = vComp(Y)

                    Set vComp(Y) = swComp

                End If

            ElseIf vComp(I).Name > vComp(Y).Name Then

                Set swComp = vComp(I)

                Set vComp(I) = vComp(Y)

                Set vComp(Y) = swComp

            End If

        Next Y

    Next I

    

    For I = UBound(vComp) - 1 To 0 Step -1

        If Flag = False Then

            swAssy.ReorderComponents vComp(I), swFolder, swReorderComponents_FirstInFolder

        Else

            swAssy.ReorderComponents vComp(I), vComp(I + 1), swReorderComponents_Before

        End If

    Next I

    

End Function