Permet de supprimer tout les contrainte d'assemblage automatiquement.




Public Sub DeleteAllContraints()

Dim oDoc As AssemblyDocument
Set oDoc = ThisApplication.ActiveDocument

Dim oCompDef As AssemblyComponentDefinition
Set oCompDef = oDoc.ComponentDefinition

oDoc.SelectSet.Clear

Dim oConstr As AssemblyConstraint
For Each oConstr In oCompDef.Constraints
oDoc.SelectSet.Select oConstr
Next

Dim oCtrlDef As ControlDefinition
Set oCtrlDef = ThisApplication.CommandManager.ControlDefinitions.Item("AppDeleteCmd")

oCtrlDef.Execute

End Sub





Fonctionne bien sous Inventor 2009
Dan

Pour Supprimer tout les contraintes d'assemblage et tout ''grounded''.



Public Sub DelAllContraintsandAllGrounded()

Dim oDoc As AssemblyDocument
Set oDoc = ThisApplication.ActiveDocument
Dim odef As AssemblyComponentDefinition
Set odef = oDoc.ComponentDefinition
Dim oOcc As ComponentOccurrence
For Each oOcc In odef.Occurrences
oDoc.SelectSet.Select oOcc
Dim oCompDef As AssemblyComponentDefinition
Set oCompDef = oDoc.ComponentDefinition
oDoc.SelectSet.Clear
Dim oConstr As AssemblyConstraint
For Each oConstr In oCompDef.Constraints
oDoc.SelectSet.Select oConstr
Next

Dim oCtrlDef As ControlDefinition
Set oCtrlDef = ThisApplication.CommandManager.ControlDefinitions.Item("AppDeleteCmd")
oCtrlDef.Execute

On Error GoTo NoIAMOpen
Next
If ThisApplication.Documents.Count = 0 Then
MsgBox "Ouvrir l'assemblage.", vbExclamation, "Keine Baugruppe"
Exit Sub
End If
If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
MsgBox "Ouvrir l'assemblage.", vbExclamation, "Keine Baugruppe"
Exit Sub
End If
Dim oAsm As AssemblyDocument
Set oAsm = ThisApplication.ActiveDocument
ForAllComponents oAsm.ComponentDefinition.Occurrences
Exit Sub
NoIAMOpen:
MsgBox ("Cette Command fonctionne seulement en mode Assemblages, SVP Activez votre assemblage!!!!")
End Sub



Fonctionne bien sous Inventor 2009