Anonymous
546 Views, 1 Reply
07-10-2017
10:52 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
07-10-2017
10:52 PM
Hello,
I found the following code in a forum.
What I need is a code, that constrains all components in an assembly without selecting them.
"For each..." But my programming skills are only basics. And I cant get it to work.
Anyone have a code or can edit the existing one?
I need constrains. I found grounding of components already. But sometimes I need to move a part or subassembly a bit away from ground. With constrains it is easyer for me.
Public Sub bewegeKomponenteZumUrsprung()
Dim oDoc As Document
Dim oAsmCompDef As AssemblyComponentDefinition
Dim oAsmWorkPlane(1 To 3) As WorkPlane
Dim oOcc2 As ComponentOccurrence
Dim oPartPlane2 As WorkPlane
Dim oAsmPlane2 As WorkPlaneProxy
Dim oSelectSet As SelectSet
Dim i As Long
Set oDoc = ThisApplication.ActiveDocument
If oDoc.DocumentType <> kAssemblyDocumentObject Then
MsgBox "Dieses Makro funktioniert nur in einer Baugruppe! Dieses Makro fixiert eine Bauteil/Baugruppe im Ursprung der aktuellen Baugruppe.", vbCritical
Exit Sub
End If
Set oSelectSet = ThisApplication.ActiveDocument.SelectSet
' Validate the correct data is in the select set.
If oSelectSet.Count <> 1 Then
MsgBox "Es darf nur ein einzelnes Element ausgewählt sein!", vbCritical
Exit Sub
End If
'Debug.Print oSelectSet.Item(1).Type
If oSelectSet.Item(1).Type = 67113776 Then
' Die Nummer ist "hart verdrahtet", weil ich sonst keine andere Möglichkeit/Konstante gefunden habe.
Set oAsmCompDef = ThisApplication.ActiveDocument.ComponentDefinition
Set oOcc2 = oAsmCompDef.Occurrences.ItemByName(oSelectSet.Item(1).Name)
For i = 1 To 3
' Arbeitsebenen der Baugruppe auslesen
Set oAsmWorkPlane(i) = ThisApplication.ActiveDocument.ComponentDefinition.WorkPlanes.Item(i)
'Arbeitsebene des Bauteils/Baugruppe auslesen
Set oPartPlane2 = oOcc2.Definition.WorkPlanes.Item(i)
' Proxy Berechnung (Bauteil-Koords -> Baugruppen-Koords)
Call oOcc2.CreateGeometryProxy(oPartPlane2, oAsmPlane2)
' fluchtende Abhängigkeit vergeben
Call oAsmCompDef.Constraints.AddFlushConstraint(oAsmWorkPlane(i), oAsmPlane2, 0)
Next i
Else
MsgBox "Es muß ein Bauteil oder eine Baugruppe ausgewählt sein!", vbCritical
End If
End Subhttp://ww3.cad.de/foren/ubb/Forum258/HTML/000379.shtml
Solved! Go to Solution.
Anonymous
in reply to:
Anonymous
07-11-2017
02:49 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
07-11-2017
02:49 AM
Worked for me now in the combination if these codes:
Public Sub AlignOccurrencesWithConstraints()
Dim oAsmDoc As AssemblyDocument
Set oAsmDoc = ThisApplication.ActiveDocument
' Get the assembly component definition.
Dim oAsmDef As AssemblyComponentDefinition
Set oAsmDef = oAsmDoc.ComponentDefinition
' Get all of the leaf occurrences of the assembly.
Dim oLeafOccs As ComponentOccurrencesEnumerator
Set oLeafOccs = oAsmDef.Occurrences.AllLeafOccurrences
' Get the occurrences in the select set.
Dim occurrenceList As New Collection
'Dim entity As Object
' Iterate through the occurrences and print the name.
Dim oOcc As ComponentOccurrence
'Dim occurrenceList As New Collection
Dim oAssyDoc As Inventor.AssemblyDocument
Set oAddyDoc = ThisApplication.ActiveDocument
Dim oConstraints As AssemblyConstraints
Set oConstraints = oAsmDef.constraints
Dim oConstraint As AssemblyConstraint
If MsgBox("Achtung, dies löscht alle Abhängigkeiten! Wirklich ALLE Abhänigkeiten löschen?", vbYesNo + vbQuestion) = vbYes Then
Aufheben
For Each oConstraint In oConstraints
'MsgBox ("HELLO")
oConstraint.Delete
Next
For Each oOcc In oLeafOccs
occurrenceList.Add oOcc
'MsgBox ("HELLO")
Next
If occurrenceList.Count < 2 Then
MsgBox "At least two occurrences must be selected."
Exit Sub
End If
' This assumes the first selected occurrence is the "base"
' and will constrain the base workplanes of all the other parts
' to the base workplanes of the first part. If there are
' constraints on the other they end up being over constrained.
' Get the planes from the base part and create proxies for them.
Dim baseOccurrence As ComponentOccurrence
Set baseOccurrence = occurrenceList.Item(1)
Dim BaseXY As WorkPlane
Dim BaseYZ As WorkPlane
Dim BaseXZ As WorkPlane
Call GetPlanes(baseOccurrence, BaseXY, BaseYZ, BaseXZ)
Dim constraints As AssemblyConstraints
Set constraints = oAsmDoc.ComponentDefinition.constraints
' Iterate through the other occurrences
Dim i As Integer
For i = 2 To occurrenceList.Count
Dim thisOcc As ComponentOccurrence
Set thisOcc = occurrenceList.Item(i)
' Move it to the base occurrence so that if the base is
' not fully constrained it shouldn't move when the flush
' constraints are added.
thisOcc.Transformation = baseOccurrence.Transformation
' Get the planes from the occurrence
Dim occPlaneXY As WorkPlane
Dim occPlaneYZ As WorkPlane
Dim occPlaneXZ As WorkPlane
Call GetPlanes(thisOcc, occPlaneXY, occPlaneYZ, occPlaneXZ)
' Add the flush constraints.
Call constraints.AddFlushConstraint(BaseXY, occPlaneXY, 0)
Call constraints.AddFlushConstraint(BaseYZ, occPlaneYZ, 0)
Call constraints.AddFlushConstraint(BaseXZ, occPlaneXZ, 0)
Next
GroundAndFix
End If
End Sub' Utility function used by the AlignOccurrencesWithConstraints macro. ' Given an occurrence it returns the base work planes that are in ' the part or assembly the occurrence references. It gets the ' proxies for the planes since it needs the work planes in the ' context of the assembly and not in the part or assembly document ' where they actually exist. Private Sub GetPlanes(ByVal Occurrence As ComponentOccurrence, ByRef BaseXY As WorkPlane, ByRef BaseYZ As WorkPlane, ByRef BaseXZ As WorkPlane) ' Get the work planes from the definition of the occurrence. ' These will be in the context of the part or subassembly, not ' the top-level assembly, which is what we need to return. Set BaseXY = Occurrence.Definition.WorkPlanes.Item(3) Set BaseYZ = Occurrence.Definition.WorkPlanes.Item(1) Set BaseXZ = Occurrence.Definition.WorkPlanes.Item(2) ' Create proxies for these planes. This will act as the work ' plane in the context of the top-level assembly. Call Occurrence.CreateGeometryProxy(BaseXY, BaseXY) Call Occurrence.CreateGeometryProxy(BaseYZ, BaseYZ) Call Occurrence.CreateGeometryProxy(BaseXZ, BaseXZ) End Sub
Public Sub GroundAndFix()
Dim assemblydoc As AssemblyDocument
Set assemblydoc = ThisApplication.ActiveDocument
Dim assemblyDef As AssemblyComponentDefinition
Set assemblyDef = assemblydoc.ComponentDefinition
' Create a matrix. It is initialized as an identity matrix
' which means it defines a position as the origin and aligned
' with the global x, y, and z axes.
Dim transGeom As TransientGeometry
Set transGeom = ThisApplication.TransientGeometry
Dim baseTransform As Matrix
Set baseTransform = transGeom.CreateMatrix
' Create collections to load the occurrences into.
Dim transObjects As TransientObjects
Set transObjects = ThisApplication.TransientObjects
Dim occList As ObjectCollection
Set occList = transObjects.CreateObjectCollection
Dim transformList As ObjectCollection
Set transformList = transObjects.CreateObjectCollection
' Iterate through all of the occurrences.
Dim Occurrence As ComponentOccurrence
For Each Occurrence In assemblyDef.Occurrences
' Add each occurrence to the list.
occList.Add Occurrence
' Add the transform to the list.
transformList.Add baseTransform
' Ground each occurrence. This is ok to do here
' because the move will ignore the ground condition.
Occurrence.Grounded = True
Next
' Reposition all of the occurrences. The TransformOccurrences
' method was new in Inventor 2009.
Set assemblyDef = assemblydoc.ComponentDefinition
Call assemblyDef.TransformOccurrences(occList, transformList)
End Sub