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
