CATIA V5 Macro - Get Inflection Points

CATIA V5 Macro - Get Inflection Points

Please read Liability Disclaimer and License Agreement CAREFULLY

This macro is designed to streamline the process of creating inflection points on curves in Catia V5.

By selecting a curve and running the macro, you can easily generate inflection points along the curve, saving you time and effort.

Inflection points are points on a curve where the curvature changes sign, and they are often used in engineering and design applications to analyze and optimize the behavior of curves. With this macro, you can quickly add inflection points to curves for further analysis and refinement.

This Catia V5 VBA macro is easy to use and comes with clear interface to guide you through the process.

Whether you're an experienced Catia V5 user or new to the software, this macro can help you create inflection points with ease.

Download this Catia V5 VBA macro today and start creating inflection points on your curves with just a few clicks!

Catia V5 Get Inflection Points Macro

Create a class module called "iPoint"

Public X As Double
Public Y As Double
Public Z As Double

Create a module called "Q"

Sub CATMain()
    On Error Resume Next
    Dim ActiveDoc As Document
    Set ActiveDoc = CATIA.ActiveDocument
    If ActiveDoc Is Nothing Then
        MsgBox "No document loaded!!!", vbExclamation, "Get Inflection Points Warning!"
        Exit Sub
    Else
        If TypeName(CATIA.ActiveDocument) = "PartDocument" Then
            If CATIA.ActiveDocument.Part.IsUpToDate(Prt) Then
                Set ActiveDoc = Nothing
                InflectionPoints.Show
            Else
                MsgBox PartDoc.Product.PartNumber & " not uPartDocated/is in error state!!!" & Chr(13) & _
                    "Resolve the problem(s) and try again.", vbExclamation, "Part2Prod Warning!"
                Set ActiveDoc = Nothing
                Exit Sub
            End If
        Else
            MsgBox "No CATPart in Catia active window!!!", vbExclamation, "Get Inflection Points Warning!"
            Set ActiveDoc = Nothing
            Exit Sub
        End If
    End If
    Set ActiveDoc = Nothing
End Sub

Create a form, add the controls and paste the following code

Option Explicit
Dim PrtDoc As PartDocument
Dim Prt As Part
Dim TheMeasurable 'as Measurable
Dim MyBench 'As SPAWorkbench
Dim Sel 'As Selection
Dim HB As HybridBody
Dim HSF As HybridShapeFactory
Dim myCurve 'As HybridShapeSpline
Dim AxisSys As AxisSystem
Dim AxisRef 'as Reference
Dim RefS1 As Reference
Dim MyProgress As Long
Dim MyCoord(2)
Dim forceStop As Boolean
Dim DeadCurve As HybridShapeCurveExplicit ' When user selects isoleted curve
Dim SelItem

Private Sub UserForm_Initialize()
    Set PrtDoc = CATIA.ActiveDocument
    Set Prt = PrtDoc.Part
    Set Sel = PrtDoc.Selection
    Set AxisSys = Prt.AxisSystems.Item("Absolute Axis System")
    Set AxisRef = Prt.CreateReferenceFromBRepName("RSur:(Face:(Brp:(AxisSystem.1;3);None:();Cf11:());WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)", AxisSys)
    Set MyBench = PrtDoc.GetWorkbench("SPAWorkbench")
    Set HSF = Prt.HybridShapeFactory
    On Error Resume Next
    Set SelItem = Sel.Item(1).Value
    'Debug.Print "AAA is " & myCurve.Parent.Parent.Parent.Name
    If Not TypeName(myCurve) = "Empty" Then
        Set HB = Prt.HybridBodies.GetItem(SelItem.Parent.Parent.Parent.Name)
        Set myCurve = HB.HybridShapes.GetItem(SelItem.Parent.Name)
    Else
        MsgBox "No Curve selected!!!", vbExclamation, "Get Inflection Points Warning!"
    End If
    ListBox1.ColumnCount = 4
    ListBox1.ColumnWidths = "120,70,70,70"
    ListBox1.Clear
    Label1.Caption = "Please select a curve and then press Start"
    Status.Caption = ""
    forceStop = False
End Sub
Private Sub XY_Click()
    YZ.Value = False
End Sub

Private Sub YZ_Click()
    XY.Value = False
End Sub

Private Sub InflectionStart_Click()
    On Error Resume Next
    If HB Is Nothing Then
        Set SelItem = Sel.Item(1).Value
        If Not TypeName(SelItem) = "Empty" Then
            Set HB = Prt.HybridBodies.GetItem(SelItem.Parent.Parent.Parent.Name)
            Set myCurve = HB.HybridShapes.GetItem(SelItem.Parent.Name)
        Else
            MsgBox "No Curve selected!!!", vbExclamation, "Get Inflection Points Warning!"
            Exit Sub
        End If
    End If

    If XY.Value = True Then
        MakeInfPoints (1)
    Else
        MakeInfPoints (2)
    End If
End Sub
Private Sub InflectionStop_Click()
    forceStop = True
End Sub

Private Sub InflectionExit_Click()
    Set PrtDoc = Nothing
    Set Prt = Nothing
    Set Sel = Nothing
    Set AxisSys = Nothing
    Set AxisRef = Nothing
    Set MyBench = Nothing
    Set TheMeasurable = Nothing
    Set HB = Nothing
    Set HSF = Nothing
    Unload Me
End Sub

Private Sub AddListItem(ByVal Name As String, ByVal X As Double, ByVal Y As Double, ByVal Z As Double)
    ListBox1.AddItem
    ListBox1.List(ListBox1.ListCount - 1, 0) = Name
    ListBox1.List(ListBox1.ListCount - 1, 1) = X
    ListBox1.List(ListBox1.ListCount - 1, 2) = Y
    ListBox1.List(ListBox1.ListCount - 1, 3) = Z
End Sub
Private Sub setProgress(ByVal crtVal As Long, ByVal max As Long)
    Status.Caption = " Processing point at L=" & VBA.Round(crtVal / 100, 2) & "mm prgress is " & VBA.Round(100 * (crtVal / max), 2) & "%"
End Sub
Private Sub MakeInfPoints(ByVal idx As Integer)
    Dim PoC As Object 'Point on curve
    Dim tmpref As Reference 'Temporary reference
    Dim P2, P3 As HybridShapePointOnCurve 'Points on curve as helper for circle creation
    Dim MyCircle 'As HybridShapeCircle3Points 'Circle to move on curve, used to determine inflection points
    Dim L, myStep, CrtL As Double 'Curve length, step to move on curve, current position on curve
    Dim cCenter(2) 'Circle center coordinates
    Dim PrevPoint As New iPoint 'Previous point in inflection detection
    Dim Delta As New iPoint 'Difference between current poin and Previous point in inflection detection
    Dim CrtTxt, tmpTxt As String 'used in Inflection point name, temporary string to hold point name
    Dim Found, CountSteps As Integer 'How many inflection points are found, how many steps we have counted
    Dim MidPoint As HybridShapePointOnCurve 'Point to move along the curve
    
    Found = 0
    Set RefS1 = Prt.CreateReferenceFromObject(myCurve)
    If idx = 1 Then
        CrtTxt = "XY"
    Else
        CrtTxt = "YZ"
    End If
    tmpTxt = "InfPoint-" & CrtTxt & Found
    'measure curve lenght
    Set TheMeasurable = MyBench.GetMeasurable(RefS1)
    L = Round(TheMeasurable.Length, 2) 'get curve length with 2 decimals, we use this to move the point along thecurve
    Label1.Caption = "Selected curve lengt is: " & L & "mm / Normal search mode"
    'Make the first point
    'Set PoC = MakePoC(tmpTxt, RefS1, Nothing, 0, False, True)
    'make a point on the curve named MidPoint at 0.1mm from curve start
    Set PoC = MakePoC("MidPoint", RefS1, Nothing, 0.1, False, False)
    Set MidPoint = HB.HybridShapes.GetItem("MidPoint")
    'create one point befor and one after MidPoint spaced at 0.1mm
    Set tmpref = Prt.CreateReferenceFromObject(PoC)
    Set P2 = MakePoC("P2", RefS1, tmpref, 0.1, True)
    Set P3 = MakePoC("P3", RefS1, tmpref, 0.1, False)
    'Make a circle through MidPoint, P2 and P3
    Set MyCircle = HSF.AddNewCircle3Points(Prt.CreateReferenceFromObject(P2), tmpref, Prt.CreateReferenceFromObject(P3))
    MyCircle.SetLimitation 1
    HB.AppendHybridShape MyCircle
    MyCircle.Compute
    Prt.InWorkObject = MyCircle
    Sel.Clear
    Sel.Add MyCircle
    'Change circle color to black
    Sel.VisProperties.SetRealColor 0, 0, 0, 1
    Sel.Clear
    Prt.Update
    PrevPoint.X = 0
    PrevPoint.Y = 0
    PrevPoint.Z = 0
    Found = 1
    MyProgress = L * 100
    myStep = 1
    CrtL = 0#
    'As long as we are on the curve we search for inflection points
    On Error Resume Next
    Do While CrtL < MyProgress
nextStep:         MidPoint.Ratio.Value = MidPoint.Ratio.Value + myStep
        DoEvents
        If forceStop Then Exit Sub
        'special case
        If myStep = 0.01 Then
            CountSteps = CountSteps + 1
        Else
            CountSteps = 0
        End If
        If CountSteps >= 100 Then
            MidPoint.Ratio.Value = MidPoint.Ratio.Value - 1
            Prt.Update
        End If
        'end special case
        CrtL = Round(MidPoint.Ratio.Value * 100, 0)
        Prt.Update
        'We have a line and we can't make the circle
        If Err.Number = -2147467259 Then
            Err.Clear
            GoTo nextStep
        End If
        'Get circle center and position relative to PoC
        MyCircle.GetCenter cCenter(0), cCenter(1), cCenter(2)
        PoC.GetCoordinates MyCoord
        'special case
        If CountSteps = 100 Then
            CountSteps = 0
            GoTo ForcePoint
        End If
        'end special case
        Delta.X = cCenter(0) - MyCoord(0)
        Delta.Y = cCenter(1) - MyCoord(1)
        Delta.Z = cCenter(2) - MyCoord(2)
        'compute the values depending on the support plane
        If IsInflection(Delta, PrevPoint, idx) Then
            'go back 1mm and move with 0.01mm
            Label1.Caption = "Selected curve lengt is: " & L & "mm / High resolution search mode"
            If myStep = 1 Then
                myStep = 0.01
                MidPoint.Ratio.Value = MidPoint.Ratio.Value - 1
                CrtL = Round(MidPoint.Ratio.Value * 100, 0)
            'if step is 0.01mm then create the inflection point
            Else:
ForcePoint:     myStep = 1
                tmpTxt = "InfPoint-" & CrtTxt & Found
                'make the point
                Call MakePointCoord(MyCoord(0), MyCoord(1), MyCoord(2), tmpTxt, , False)
                Prt.Update
                Set tmpref = Nothing
                Found = Found + 1
                Status.Caption = "Searching inflection points " & CrtTxt & ". Found " & Found
                Label1.Caption = "Selected curve lengt is: " & L & "mm / Normal search mode"
            End If
            Prt.Update
            PrevPoint.X = 0
            PrevPoint.Y = 0
            PrevPoint.Z = 0
            setProgress CrtL, MyProgress
            GoTo nextStep
        End If
        PrevPoint.X = Delta.X
        PrevPoint.Y = Delta.Y
        PrevPoint.Z = Delta.Z
        setProgress CrtL, MyProgress
    Loop
    With Sel
        .Clear
        .Add MyCircle
        .Add P3
        .Add P2
        .Add PoC
        .Delete
    End With
    tmpTxt = "InfPoint-" & CrtTxt & Found
    'make last point
    Set PoC = MakePoC(tmpTxt, RefS1, Nothing, 0, True, True)
    Set tmpref = Prt.CreateReferenceFromObject(PoC)
    'clean up
    Erase MyCoord
    Erase cCenter
    Set PoC = Nothing
    Set tmpref = Nothing
    Set P3 = Nothing
    Set P2 = Nothing
    Set MyCircle = Nothing
    Set PrevPoint = Nothing
    Set MidPoint = Nothing
    MsgBox "All done!!!", vbInformation, "Get Inflection Points Warning!"
End Sub

'Put Color on feature
Private Sub SetFeatureColor(ByRef MyFeature As Object, Culoare As String, Tip As Integer, Optional Thick As Long = 0)
    Dim R, G, B As Long
    Select Case Culoare
    Case "black"
        R = 0
        G = 0
        B = 0
    Case "white"
        R = 255
        G = 255
        B = 255
    Case "blue"
        R = 0
        G = 0
        B = 255
    Case "green"
        R = 0
        G = 255
        B = 0
    Case "yellow"
        R = 255
        G = 255
        B = 0
    Case "purple"
        R = 255
        G = 0
        B = 255
    End Select
    Prt.Update
    With Sel
        .Clear
        .Add MyFeature
        .VisProperties.SetRealColor R, G, B, 1
        If Tip Then .VisProperties.SetSymbolType Tip
        If Thick Then .VisProperties.SetRealWidth Thick, 1
        .Clear
    End With
    DoEvents
End Sub

Sub MakePointCoord(ByVal MyX As Double, ByVal MyY As Double, ByVal MyZ As Double, pName As String, _
                    Optional ByVal SplineObj As HybridShapeSpline = Nothing, _
                    Optional ProgUpdate As Boolean = False)
    Dim MyPoint As HybridShapePointCoord
    Set MyPoint = HSF.AddNewPointCoord(MyX, MyY, MyZ)
    MyPoint.RefAxisSystem = AxisRef
    MyPoint.Name = pName
    AddListItem pName, MyX, MyY, MyZ
    HB.AppendHybridShape MyPoint
    MyPoint.Compute
    SetFeatureColor MyPoint, "black", 6
    If Not SplineObj Is Nothing Then
        SplineObj.AddPointWithConstraintExplicit MyPoint, Nothing, -1#, 1, Nothing, 0#
        'SetFeatureHide MyPoint
    End If
    Set MyPoint = Nothing
    'If ProgUpdate Then MyProgress.Value = MyProgress.Value + 1
    Prt.Update
    DoEvents
End Sub

Function MakePoC(pName As String, ByVal MyRef1 As Reference, ByVal MyRef2 As Reference, Dist As Double, Side As Boolean, Optional FromDist As Boolean = False) As HybridShapePointOnCurve
    Dim TmpPoC As HybridShapePointOnCurve
    If FromDist Then
        Set TmpPoC = HSF.AddNewPointOnCurveFromDistance(MyRef1, Dist, Side)
    Else
        Set TmpPoC = HSF.AddNewPointOnCurveWithReferenceFromDistance(MyRef1, MyRef2, Dist, Side)
    End If
    HB.AppendHybridShape TmpPoC
    With TmpPoC
        .Name = pName
        .DistanceType = 1
        .Compute
    End With
    Set MakePoC = TmpPoC
    Set TmpPoC = Nothing
End Function

Function IsInflection(ByVal CrtDelta As iPoint, ByVal PrevP As iPoint, CrtPlane As Integer) As Boolean
    If CrtPlane = 1 Then 'XY
        If (CrtDelta.X > 0 And PrevP.X < 0) Or (CrtDelta.X < 0 And PrevP.X > 0) Then
            IsInflection = True
        Else
            IsInflection = False
        End If
    Else: 'YZ
        If (CrtDelta.Y > 0 And PrevP.Y < 0) Or (CrtDelta.Y < 0 And PrevP.Y > 0) Then
            IsInflection = True
        Else
            IsInflection = False
        End If
    End If
End Function

Comments powered by CComment

Who’s online

We have 106 guests and no members online