Hallo
Und hier ist das vollständige Beispiel:
Option Explicit
' ce code nécessite que la référence "Microsoft Scripting Runtime" soit activée
Dim MonDico As New Scripting.Dictionary
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim featureMgr As SldWorks.FeatureManager
Dim feature As SldWorks.feature
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim bRet As Boolean
Dim Compteur As Long
Dim TestValeurDico As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent
TraverseComponent swRootComp, swRootComp.Name2, "catégorie", "visserie"
Compteur = 1
For Each TestValeurDico In MonDico.Keys
Classement swModel, MonDico(TestValeurDico), Compteur, "Visserie"
Compteur = Compteur + 1
Next TestValeurDico
Set MonDico = Nothing
Set swModel = swApp.ActiveDoc
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent
TraverseComponent swRootComp, swRootComp.Name2, "catégorie", "Fourniture industrielle"
Compteur = 1
For Each TestValeurDico In MonDico.Keys
Classement swModel, MonDico(TestValeurDico), Compteur, "FI"
Compteur = Compteur + 1
Next TestValeurDico
Set MonDico = Nothing
End Sub
Sub TraverseComponent(swComp As SldWorks.Component2, nomAsm As String, nomVar As String, resultVar As String)
Dim vChildCompArr As Variant
Dim vChildComp As Variant
Dim swChildComp As SldWorks.Component2
Dim swSelModel As SldWorks.ModelDoc2
Dim swCompConfig As SldWorks.Configuration
Dim Compteur As Long
Compteur = 1
vChildCompArr = swComp.GetChildren
For Each vChildComp In vChildCompArr
Set swChildComp = vChildComp
If Not swChildComp Is Nothing Then
Set swSelModel = swChildComp.GetModelDoc2
GetPropChildren swSelModel, nomAsm, swChildComp.Name2, nomVar, resultVar, Compteur
End If
Compteur = Compteur + 1
Next
End Sub
Sub GetPropChildren(swChild As SldWorks.ModelDoc2, nomAsm As String, nomPrt As String, nomVar As String, resultVar As String, Cle As Long)
Dim swModelDocExtension As SldWorks.ModelDocExtension
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim nbrProps As Long
Dim vpropsnames As Variant
Dim k As Long
Dim valeur As String
Dim val As String
Dim valout As String
Dim boolstatus As Boolean
Set swModelDocExtension = swChild.Extension
Set swCustPropMgr = swModelDocExtension.CustomPropertyManager("")
nbrProps = swCustPropMgr.count
vpropsnames = swCustPropMgr.GetNames
For k = 0 To nbrProps - 1
If vpropsnames(k) = nomVar Then
boolstatus = swCustPropMgr.Get4(nomVar, False, val, valout)
If valout = resultVar Then
valeur = nomPrt & "@" & nomAsm
If Not MonDico.Exists(Cle) Then
MonDico.Add Cle, valeur
End If
End If
End If
Next k
End Sub
Sub Classement(swModel As SldWorks.ModelDoc2, nomComposant As String, Nbr As Long, nomDossier As String)
Dim swAssy As SldWorks.AssemblyDoc
Dim featureMgr As SldWorks.FeatureManager
Dim feature As SldWorks.feature
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim bRet As Boolean
Dim modelDocExt As SldWorks.ModelDocExtension
Dim selectionMgr As SldWorks.selectionMgr
Dim selObj As Object
Dim status As Long
Dim count As Long
Dim i As Long
Dim componentToMove As SldWorks.Component2
Dim componentsToMove() As Object
Dim retVal As Boolean
swModel.ClearSelection2 True
Set modelDocExt = swModel.Extension
Set selectionMgr = swModel.SelectionManager
status = modelDocExt.SelectByID2(nomComposant, "COMPONENT", 0, 0, 0, True, 0, Nothing, 0)
Set selObj = selectionMgr.GetSelectedObject6(Nbr, -1)
count = selectionMgr.GetSelectedObjectCount2(0)
ReDim componentsToMove(count - 1)
For i = 0 To count - 1
Set componentToMove = selectionMgr.GetSelectedObjectsComponent4(i + 1, 0)
Set componentsToMove(i) = componentToMove
Next
Dim erreur As String
erreur = "Oui"
Set swAssy = swModel
Set featureMgr = swAssy.FeatureManager
Set feature = swModel.FirstFeature
Do While Not feature Is Nothing
If feature.Name = nomDossier Then
erreur = "Non"
End If
Set feature = feature.GetNextFeature
Loop
If erreur = "Oui" Then
Set feature = featureMgr.InsertFeatureTreeFolder2(swFeatureTreeFolder_EmptyBefore)
feature.Name = nomDossier
End If
Set feature = swAssy.FeatureByName(nomDossier)
retVal = swAssy.ReorderComponents(componentsToMove, feature, swReorderComponents_LastInFolder)
swModel.ClearSelection2 True
End Sub
Herzliche Grüße
macroranking3d.swp
