Hello Georg,
i've made some Code like this:
its not complete. When i have time, i will add some filters for the thread collisions.
Sub Kollision_Prüfen_Gesamt()
'On Error Resume Next
'Auf Bg zugreifen
Dim oApp As Inventor.Application
Set oApp = ThisApplication
Dim oAsmDoc As AssemblyDocument
Set oAsmDoc = ThisApplication.ActiveDocument
Dim oAsmCompDef As AssemblyComponentDefinition
Set oAsmCompDef = oAsmDoc.ComponentDefinition
Call oAsmDoc.BrowserPanes.ActivePane.TopNode.DoSelect
'Pos. 1 aktivieren
Call oAsmCompDef.RepresentationsManager.PositionalRepresentations.Item(1).Activate
'Set erstellen
Dim oAllOccurrences As ObjectCollection
Set oAllOccurrences = ThisApplication.TransientObjects.CreateObjectCollection
'Nicht sichtbare entfernen
Dim oOcc As ComponentOccurrence
For Each oOcc In oAsmCompDef.Occurrences
If oOcc.Visible = True Then
Call oAllOccurrences.Add(oOcc)
End If
Next
'Kollisionen berechnen
Dim oResults As InterferenceResults
Set oResults = oAsmCompDef.AnalyzeInterference(oAllOccurrences)
'Bodys erstellen
Dim oResult As InterferenceResult
Dim oTotalBodyRed As SurfaceBody
Dim oTotalBodyGreen As SurfaceBody
Dim oTotalBodyThreadLength As SurfaceBody
For Each oResult In oResults
Dim oHelpBody As SurfaceBody
Set oHelpBody = Nothing
Dim ThreadVorhandenLarge As Boolean
Dim ThreadVorhandenSmall As Boolean
ThreadVorhandenLarge = False
ThreadVorhandenSmall = False
Dim ThreadOffen As Boolean
ThreadOffen = True
Dim oCylinderFaceLarge As Face
Dim oCylinderFaceSmall As Face
Set oCylinderFaceLarge = Nothing
Set oCylinderFaceSmall = Nothing
Dim oCylinderLarge As Cylinder
Dim oCylinderSmall As Cylinder
Set oCylinderLarge = Nothing
Set oCylinderSmall = Nothing
'Bohrungsgrößen:
Dim aussen_Arr
Dim kern_Arr
'Gewinde DIN M2.5-M30
aussen_Arr = Array(2.5, 3, 4, 5, 6, 8, 10, 12, 16, 20, 24, 30, 5, 6)
kern_Arr = Array(2.013, 2.459, 3.242, 4.134, 4.917, 6.647, 8.376, 10.106, 13.835, 17.294, 20.752, 26.211, 4.3, 4.9)
'Flächen mit Bohrungsgrößen herausfiltern
For i = 0 To UBound(aussen_Arr) Step 1
Dim oFace As Face
For Each oFace In oResult.InterferenceBody.Faces
If oFace.SurfaceType = kCylinderSurface And oResult.InterferenceBody.Faces.Count = 4 Then
If Round(oFace.Geometry.Radius * 2 * 10, 5) = aussen_Arr(i) Then
ThreadVorhandenLarge = True
Set oCylinderFaceLarge = oFace
Set oCylinderLarge = oFace.Geometry
End If
If Round(oFace.Geometry.Radius * 2 * 10, 5) = kern_Arr(i) Then
ThreadVorhandenSmall = True
Set oCylinderFaceSmall = oFace
Set oCylinderSmall = oFace.Geometry
End If
End If
Next
If ThreadVorhandenLarge = True And ThreadVorhandenSmall = True Then Exit For
Next
'Prüfen, ob Kerndurchmesser beidseitig offen ist
'Prüfen, ob Bohrungen konzentrisch
Dim Clash As Boolean
Clash = True
If ThreadVorhandenLarge = True And ThreadVorhandenSmall = True Then
If Round(oCylinderLarge.BasePoint.DistanceTo(oCylinderSmall.BasePoint), 5) <> 0 Then
Dim oSlaintVector As Vector
Set oSlaintVector = oCylinderLarge.BasePoint.VectorTo(oCylinderSmall.BasePoint)
If oSlaintVector.IsParallelTo(oCylinderSmall.AxisVector.AsVector) Then
Clash = False
End If
Else
Clash = False
End If
End If
Dim ThreadLengthClash As Boolean
ThreadLengthClash = False
'Längencheck durch Volumenprüfung
If ThreadVorhandenLarge = True And ThreadVorhandenSmall = True And Clash = False Then
Dim VolumeLarge As Double
VolumeLarge = 4 * Atn(1) * ((oCylinderLarge.Radius) ^ 2 - (oCylinderSmall.Radius) ^ 2) * oCylinderLarge.Radius * 2 * 2
Dim VolumeSmall As Double
VolumeSmall = 4 * Atn(1) * ((oCylinderLarge.Radius) ^ 2 - (oCylinderSmall.Radius) ^ 2) * oCylinderLarge.Radius * 2
If oResult.Volume > VolumeLarge Or oResult.Volume < VolumeSmall Then
ThreadLengthClash = True
End If
End If
'Body hinzufügen
If Clash = True Then
If oTotalBodyRed Is Nothing Then
Set oTotalBodyRed = oResult.InterferenceBody
Else
Call ThisApplication.TransientBRep.DoBoolean(oTotalBodyRed, oResult.InterferenceBody, kBooleanTypeUnion)
End If
End If
If ThreadLengthClash = True And Clash = False Then
If oTotalBodyThreadLength Is Nothing Then
Set oTotalBodyThreadLength = oResult.InterferenceBody
Else
Call ThisApplication.TransientBRep.DoBoolean(oTotalBodyThreadLength, oResult.InterferenceBody, kBooleanTypeUnion)
End If
End If
If ThreadLengthClash = False And Clash = False Then
If oTotalBodyGreen Is Nothing Then
Set oTotalBodyGreen = oResult.InterferenceBody
Else
Call ThisApplication.TransientBRep.DoBoolean(oTotalBodyGreen, oResult.InterferenceBody, kBooleanTypeUnion)
End If
End If
Next
'Neues Teil erstellen (nicht sichtbar)
Dim oResultPartRed As PartDocument
If Not oTotalBodyRed Is Nothing Then
If oResultPartRed Is Nothing Then Set oResultPartRed = ThisApplication.Documents.Add(kPartDocumentObject, "M:\PDS2014\Templates\Norm.ipt", False)
'Set oResultPart = ThisApplication.Documents.Add(kPartDocumentObject, ThisApplication.FileManager.GetTemplateFile(kPartDocumentObject), False)
End If
Dim oResultPartGreen As PartDocument
If Not oTotalBodyGreen Is Nothing Then
If oResultPartGreen Is Nothing Then Set oResultPartGreen = ThisApplication.Documents.Add(kPartDocumentObject, "M:\PDS2014\Templates\Norm.ipt", False)
'Set oResultPart = ThisApplication.Documents.Add(kPartDocumentObject, ThisApplication.FileManager.GetTemplateFile(kPartDocumentObject), False)
End If
Dim oResultPartYellow As PartDocument
If Not oTotalBodyThreadLength Is Nothing Then
If oResultPartYellow Is Nothing Then Set oResultPartYellow = ThisApplication.Documents.Add(kPartDocumentObject, "M:\PDS2014\Templates\Norm.ipt", False)
'Set oResultPart = ThisApplication.Documents.Add(kPartDocumentObject, ThisApplication.FileManager.GetTemplateFile(kPartDocumentObject), False)
End If
Dim oFeature As PartFeature
If Not oTotalBodyRed Is Nothing Then
Set oFeature = oResultPartRed.ComponentDefinition.Features.NonParametricBaseFeatures.Add(oTotalBodyRed)
oFeature.Name = "TotalBodyRed"
End If
If Not oTotalBodyGreen Is Nothing Then
Set oFeature = oResultPartGreen.ComponentDefinition.Features.NonParametricBaseFeatures.Add(oTotalBodyGreen)
oFeature.Name = "TotalBodyGreen"
End If
If Not oTotalBodyThreadLength Is Nothing Then
Set oFeature = oResultPartYellow.ComponentDefinition.Features.NonParametricBaseFeatures.Add(oTotalBodyThreadLength)
oFeature.Name = "oTotalBodyThreadLength"
End If
'Occurrence erstellen
Dim trans As Matrix
Set trans = ThisApplication.TransientGeometry.CreateMatrix
If Not oResultPartRed Is Nothing Then
Set oOcc = oAsmCompDef.Occurrences.AddByComponentDefinition(oResultPartRed.ComponentDefinition, trans)
Call oOcc.SetRenderStyle(kOverrideRenderStyle, oAsmDoc.RenderStyles.Item("ACAD-Rot"))
oOcc.Name = "Kollisionen"
End If
If Not oResultPartGreen Is Nothing Then
Set oOcc = oAsmCompDef.Occurrences.AddByComponentDefinition(oResultPartGreen.ComponentDefinition, trans)
Call oOcc.SetRenderStyle(kOverrideRenderStyle, oAsmDoc.RenderStyles.Item("ACAD-Grün"))
oOcc.Name = "Geprüft"
End If
If Not oResultPartYellow Is Nothing Then
Set oOcc = oAsmCompDef.Occurrences.AddByComponentDefinition(oResultPartYellow.ComponentDefinition, trans)
Call oOcc.SetRenderStyle(kOverrideRenderStyle, oAsmDoc.RenderStyles.Item("ACAD-Gelb"))
oOcc.Name = "Gewinde zu kurz oder zu lang"
End If
End Sub
You have to change the path of the templatefile. Or you can activate the three lines with the "GetTemplateFile". In IV2014 the "GetTemplateFile" make some trouble so I don't use it.
