Code:
Sub CATMain()
CATIA.refreshDisplay = False''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Start_Messagebox
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Dim msgResult As MsgBoxResult
msgResult = MsgBox( "This macro generates constant angle layup courses. The input elements must be HybridShape Objects (No sketches)! Following inputs are needed:" & Chr(10) & Chr(10) & " - Course width" & Chr(10) & " - Ply number" & Chr(10) & " - Layup direction" & Chr(10) & " - Support surface" & Chr(10) & " - Boundary of the ply" & Chr(10) & " - 0° reference direction" & Chr(10) & " - StartPoint" & Chr(10) & Chr(10) & "Do you wish to proceed?", 1, "Layup geometry: Rosette Rule")
If msgResult = 2 Then
Exit Sub
End If
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Defintions ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Set activeDoc = CATIA.ActiveDocument
Set activePart = activeDoc.Part
Set hybridBodies1 = activePart.HybridBodies
Set hybridBody0 = hybridBodies1.Item("Geometrical Set.1")
Set hybridShapes0 = hybridBody0.HybridShapes
Set hybridShapeFactory1 = activePart.HybridShapeFactory
Set selection1 = activeDoc.Selection
Dim hybBods(4) As HybridBody
Dim inputs(4) As HybridShape
Dim SelVisProp As VisProperties 'VisProperties variable for changing appearance of the courses created
Dim InputObjectType(0)
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Inputs ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Enter the geodesic distance between the startpoints of the courses.
courseWidth = 38.1
courseWidth = InputBox("Enter geodesic distance between the startpoints of the courses.","Input [mm]",courseWidth)
If (courseWidth = "") Then
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Enter ply number.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
plyNo = 1
plyNo = InputBox("Enter the number of the ply.","Input",plyNo)
If (plyNo = "") Then
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Enter the fiber direction angle.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Selection1.Clear
layupDir = 0
layupDir = Inputbox("Enter the layup direction", "Input [°]" , layupDir)
If (layupDir = "") Then
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Ask user to select the support surface.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fläche anwählen
InputObjectType(0) = "BiDim"
Selection1.Clear
Status = Selection1.SelectElement2(InputObjectType, "Select the support surface.", True)
If (Status = "Cancel") Then
Exit Sub
Else
Set supSurf = Selection1.Item(1).Value
Set inputs(1) = supSurf
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Ask user to select the Boundary.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Parallele Kurve auf Fläche anwählen
InputObjectType(0) = "MonoDim"
Selection1.Clear
Status = Selection1.SelectElement2(InputObjectType, "Select the ply boundary.", True)
If (Status = "Cancel") Then
MsgBox "Canceled by user or selected element was a sketch."
Exit Sub
ElseIF (TypeName(Selection1.Item(1).Value) = "Sketch") Then
MsgBox "Canceled by user or selected element was a sketch."
Exit Sub
Else
Set boundary = Selection1.Item(1).Value
Set inputs(2) = boundary
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Ask user to select the 0 degrees reference direction
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Achse als Referenz anwählen
Selection1.Clear
Status = Selection1.SelectElement2(InputObjectType, "Select the 0° reference direction.", True)
If (Status = "Cancel") Then
MsgBox "Canceled by user or selected element was a sketch."
Exit Sub
ElseIf (TypeName(Selection1.Item(1).Value) = "Sketch") Then
MsgBox "Canceled by user or selected element was a sketch."
Exit Sub
Else
Set refDir = Selection1.Item(1).Value
Set inputs(3) = refDir
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Ask user to select the Start Point
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Startpunkt anwählen
InputObjectType(0) = "ZeroDim"
Selection1.Clear
Status = Selection1.SelectElement2(InputObjectType, "Select the StartPoint.", True)
If (Status = "Cancel") Then
MsgBox "Canceled by user or selected element was a sketch!"
Exit Sub
ElseIf (TypeName(Selection1.Item(1).Value) = "Sketch") Then
MsgBox "Canceled by user or selected element was a sketch!"
Exit Sub
Else
Set startPt = Selection1.Item(1).Value
Set inputs(4) = startPt
End If
InputObjectType(0) = "AnyObject"
Dim seltype
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Preparation of GeoSets ++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Creation of geometrical sets and their HybridShapes
'Check whether the GeoSets exist. If not, create them.
Selection1.Clear
On Error Resume Next
Selection1.Add hybridBodies1.Item("Course_Width " & cstr(courseWidth) & " mm" & "__Layup direction " & cstr(layupDir) & "°")
If Err.Number <> 0 Then
Err.Clear
Set hybridBody1 = hybridBodies1.Add()
hybridBody1.Name = "Course_Width " & cstr(courseWidth) & "mm" & "__Layup direction " & cstr(layupDir) & "°"
Set hybridShapes1 = hybridBody1.HybridShapes
Selection1.Clear
avtivePart.Update
Else
Set hybridBody1 = Selection1.Item(1).Value
Set hybridShapes1 = hybridBody1.HybridShapes
End If
Set hybBods(0) = hybridBody1
Set hybridBodies2 = hybridBody1.HybridBodies
Selection1.Clear
On Error Resume Next 'weist Makro an, einen Laufzeitfehler zu überspringen und zur
'nächsten Anweisung zu springen___gilt nur für jeweilige Funktion oder Unterroutine!
Selection1.Add hybridBodies2.Item("Extracts")
If Err.Number <> 0 Then
Err.Clear
Set hybridBody2 = hybridBodies2.Add()
hybridBody2.Name = "Extracts" 'Surface, Boundary, Startpoint
Set hybridShapes2 = hybridBody1.HybridShapes
Selection1.Clear
activePart.Update
Else
Set hybridBody1 = Selection1.Item(1).Value
Set hybridShapes2 = hybridBody1.HybridShapes
End If
Set hybBods(1) = hybridBody2
Selection1.Clear
On Error Resume Next
Selection1.Add hybridBodies2.Item("New_Rosette")
If Err.Number <> 0 Then
Err.Clear
Set hybridBody3 = hybridBodies2.Add()
hybridBody3.Name = "New_Rosette"
Set hybridShapes3 = hybridBody3.HybridShapes
Selection1.Clear
activePart.Update
Else
Set hybridBody3 = Selection1.Item(1).Value
Set hybridShapes3 = hybridBody3.HybridShapes
End If
Set hybBods(2) = hybridBody3
Selection1.Clear
On Error Resume Next
Selection1.Add hybridBodies2.Item("Support_Geometry")
If Err.Number <> 0 Then
Err.Clear
Set hybridBody4 = hybridBodies2.Add()
hybridBody4.Name = "Support_Geometry"
Set hybridShapes4 = hybridBody4.HybridShapes
Selection1.Clear
activePart.Update
Else
Set hybridBody4 = Selection1.Item(1).Value
Set hybridShapes4 = hybridBody4.HybridShapes
End If
Set hybBods(3) = hybridBody4
Selection1.Clear
On Error Resume Next
Selection1.Add hybridBodies2.Item("nicht_benannt")
If Err.Number <> 0 Then
Err.Clear
Set hybridBody5 = hybridBodies2.Add()
hybridBody5.Name = "nicht_benannt"
Set hybridShapes5 = hybridBody5.HybridShapes
Selection1.Clear
activePart.Update
Else
Set hybridBody5 = Selection1.Item(1).Value
Set hybridShapes5 = hybridBody5.HybridShapes
End If
Set hybBods(4) = hybridBody5
Selection1.Clear
On Error Resume Next
Selection1.Add hybridBodies2.Item("Courses")
If Err.Number <> 0 Then
Err.Clear
Set hybridBody6 = hybridBodies2.Add()
hybridBody6.Name = "Courses"
Set hybridShapes6 = hybridBody6.HybridShapes
Selection1.Clear
activePart.Update
Else
Set hybridBody6 = Selection1.Item(1).Value
Set hybridShapes6 = hybridBody6.HybridShapes
End If
Set hybBods(5) = hybridBody6
activePart.Update
'-----------------------------
'Extracting the required geometry
'-----------------------------
'Extracting the selected surface, boundary, intial course and startpoint into the corresponding GeoSets.
'For looping through the inputs create arrays
'Extract of the support Surface
Set hybridShapeExtract1 = hybridShapeFactory1.AddNewExtract(inputs(1))
hybridShapeExtract1.Name = "Surface"
hybridShapeExtract1.PropagationType = 1
hybridShapeExtract1.ComplementaryExtract = False
hybridShapeExtract1.IsFederated = False
hybridBody2.AppendHybridShape hybridShapeExtract1
Set reference1 = activePart.CreateReferenceFromObject(hybridShapeExtract1)
'Extract of the Boundary
Set hybridShapeExtract2 = hybridShapeFactory1.AddNewExtract(inputs(2))
hybridShapeExtract2.Name = "Boundary"
hybridShapeExtract2.PropagationType = 1
hybridShapeExtract2.ComplementaryExtract = False
hybridShapeExtract2.IsFederated = False
hybridBody2.AppendHybridShape hybridShapeExtract2
Set reference2 = activePart.CreateReferenceFromObject(hybridShapeExtract2)
'Extract of the Startpoint
'Set hybridShapeExtract3 = hybridShapeFactory1.AddNewExtract(inputs(4))
' hybridShapeExtract3.Name = "Startpoint"
' hybridShapeExtract3.PropagationType = 1
' hybridShapeExtract3.ComplementaryExtract = False
' hybridShapeExtract3.IsFederated = False
' hybridBody2.AppendHybridShape hybridShapeExtract3
' Set reference3 = activePart.CreateReferenceFromObject(hybridShapeExtract3)
'Startpoint Copy as Result
Selection1.Clear
Selection1.Add inputs(4) 'Punkt anwählen
Selection1.Copy 'Kopieren von angewähtem Punkt
Selection1.Clear
Selection1.Add hybridBodies2.Item("Extracts") 'Ziel anwählen
Selection1.PasteSpecial("CATPrtResultWithOutLink")
hybridBody2.HybridShapes.Item(3).Name = "Startpoint"
Set reference3 = activePart.CreateReferenceFromObject(hybridBody2.HybridShapes.Item(3))
Selection1.Clear
activePart.Update
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Creation of the NewRosette ++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Creation of a dummy curve for startpoint on curve
Set hybridShapeLineNormal1 = hybridShapeFactory1.AddNewLineNormal(reference1, reference3, 50.000000, 0.000000, False)
hybridShapeLineNormal1.Name = "Dummy"
hybridBody3.AppendHybridShape hybridShapeLineNormal1
Set dummy = activePart.CreateReferenceFromObject(hybridShapeLineNormal1)
'NewRosette start point
Set hybridShapePointOnCurve1 = hybridShapeFactory1.AddNewPointOnCurveFromPercent(dummy, 0.000000, False)
hybridShapePointOnCurve1.Name = "StartPoint"
hybridBody3.AppendHybridShape hybridShapePointOnCurve1
Set StartPoint = activePart.CreateReferenceFromObject(hybridShapePointOnCurve1)
'Plane tangent to surface by startPoint
Set hybridShapePlaneTangent1 = hybridShapeFactory1.AddNewPlaneTangent(reference1, StartPoint)
hybridBody3.AppendHybridShape hybridShapePlaneTangent1
Set reference4 = activePart.CreateReferenceFromObject(hybridShapePlaneTangent1)
'tangentiale Linie by 0°Referenz-Richtung refDir and startpoint and tangent plane from above
Set hybridShapeLineTangency1 = hybridShapeFactory1.AddNewLineTangencyOnSupport(inputs(3), StartPoint, reference4, 200.000000, 0.000000, False)
hybridBody3.AppendHybridShape hybridShapeLineTangency1
Set reference5= activePart.CreateReferenceFromObject(hybridShapeLineTangency1)
'line normal to surface with ref1, startpoint
Set hybridShapeLineNormal2 = hybridShapeFactory1.AddNewLineNormal(reference4, StartPoint, 200.000000, 0.000000, True)
hybridBody3.AppendHybridShape hybridShapeLineNormal2
Set reference6= activePart.CreateReferenceFromObject(hybridShapeLineNormal2)
'0°Richtung_plane through two lines from 2 and 3
Set hybridShapePlane2Lines1 = hybridShapeFactory1.AddNewPlane2Lines(reference5, reference6)
hybridBody3.AppendHybridShape hybridShapePlane2Lines1
Set reference7 = activePart.CreateReferenceFromObject(hybridShapePlane2Lines1)
'Legerichtung_lay-up directionplane by angle/normal to plane
Set hybridShapePlaneAngle1 = hybridShapeFactory1.AddNewPlaneAngle(reference7, reference6, -1*layupDir, False)
hybridBody3.AppendHybridShape hybridShapePlaneAngle1
Set reference8 = activePart.CreateReferenceFromObject(hybridShapePlaneAngle1)
'Ebene 90° quer zur Legerichtung
Set hybridShapePlaneAngle2 = hybridShapeFactory1.AddNewPlaneAngle(reference8, reference6, 90.000000, False)
hybridShapePlaneAngle2.ProjectionMode = False
hybridBody3.AppendHybridShape hybridShapePlaneAngle2
Set reference9 = activePart.CreateReferenceFromObject(hybridShapePlaneAngle2)
'Intersection 0°direction_NewRosette
Set hybridShapeIntersection1 = hybridShapeFactory1.AddNewIntersection(reference7, reference1)
hybridShapeIntersection1.PointType = 0
hybridBody3.AppendHybridShape hybridShapeIntersection1
Set reference10 = activePart.CreateReferenceFromObject(hybridShapeIntersection1)
'Intersection perpendicular to the layup direction; needed for startpoints
Set hybridShapeIntersection2 = hybridShapeFactory1.AddNewIntersection(reference9, reference1)
hybridShapeIntersection2.Name = "Curve_Startpoints"
hybridShapeIntersection2.PointType = 0
hybridBody3.AppendHybridShape hybridShapeIntersection2
Set reference11 = activePart.CreateReferenceFromObject(hybridShapeIntersection2)
'Linie, die den Kurs schrittweise aufbaut___je kleiner sie ist, desto genauer die Kurserstellung, aber auch zeitintensiv
Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirection(reference9)
Set hybridShapeLinePtDir1 = hybridShapeFactory1.AddNewLinePtDirOnSupport(StartPoint, hybridShapeDirection1, reference1, 100.000000, 0.000000, False)
hybridShapeLinePtDir1.Name = "Accuracy"
hybridBody3.AppendHybridShape hybridShapeLinePtDir1
Set reference12 = activePart.CreateReferenceFromObject(hybridShapeLinePtDir1)
activePart.Update
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Creation of the courses++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
''''''''''Hier hörts bei mir auf!!!
'CATPrtResultWithOutLink Accuracy line
Selection1.Clear
Selection1.Add "Name=Accuracy"
Selection1.Copy
Selection1.Clear
Selection1.Add hybridBodies2.Item("Support_Geometry") 'target geoSet
Selection1.PasteSpecial("CATPrtResultWithOutLink")
hybridBody4 = hybridBodies2.GetItem("Accuracy")
'Put NewRosette start point at the end of the copyresult line
Set hybridShapePointOnCurve1 = hybridShapeFactory1.AddNewPointOnCurveFromPercent(reference12, 1.000000, False)
hybridShapePointOnCurve1.Name = "StartPoint"
hybridBody4.AppendHybridShape hybridShapePointOnCurve1
'Set StartPoint = activePart.CreateReferenceFromObject(hybridShapePointOnCurve1)
activePart.Update
Exit Sub
End Sub