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!
Create a class module called "iPoint"
Public X As Double
Public Y As Double
Public Z As DoubleCreate 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 SubCreate 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