Macro to look inside a geometrical set and generate a mid point on all the curves.

[CAD_ROB]

Hi any help would be great, im trying to generate a mid point on lots of curves/lines in a geometrical set. I want my macro to search inside the geometrical set named "Geom" and loop through generating a mid point on all the curves and lines in that set.

here's my first attempt and it keeps falling over at this stage: "Set hybridBody1 = hybridShapeCircleExplicit1.Item2(1).Value"

Sub CATMain()

Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument

Dim part1 As Part
Set part1 = partDocument1.Part

Dim hybridBodies1 As HybridBodies
Set hybridBodies1 = part1.HybridBodies

Dim hybridBody2 As HybridBody
Set hybridBody2 = hybridBodies1.Add()

hybridBody2.Name = "Inspection Points"

Dim hybridShapeBoundary1 As HybridShapeBoundary

Dim InputObjectType(0)
Dim SearchSelection As Selection

Dim reference As reference

Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory

Dim s As Integer

Dim BoundarySelection1 As Selection
Set BoundarySelection1 = partDocument1.Selection
BoundarySelection1.Search "Name=Geom"
Set hybridBody1 = hybridShapeCircleExplicit1.Item2(1).Value
BoundarySelection1.Search "CATGmoSearch.hybridShapeCircleExplicit1,sel"

For s = 1 To BoundarySelection1.Count

Dim BoundarySelection2 As Selection
Set BoundarySelection2 = partDocument1.Selection
BoundarySelection2.Search "Name=Geom"
Set hybridBody1 = hybridShapeCircleExplicit1.Item2(1).Value
BoundarySelection2.Search "CATGmoSearch.hybridShapeCircleExplicit1,sel"

Dim reference1 As Reference
Set reference1 = part1.CreateReferenceFromObject(hybridShapeCircleExplicit1.Item2(s).Value)

Dim hybridShapePointOnCurve1 As HybridShapePointOnCurve
Set hybridShapePointOnCurve1 = hybridShapeFactory1.AddNewPointOnCurveFromPercent(reference1, 0.500000, False)


hybridBody1.AppendHybridShape hybridShapePointOnCurve1

part1.InWorkObject = hybridShapePointOnCurve1

part1.Update


Next



End Sub

 

[kantoku]

Hi CAD_ROB.

Create a new PartDocument and try the following sample.

'vba

Option Explicit

Sub test()

    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument

    Dim pt As Part
    Set pt = doc.Part

    Dim selection1 As selection
    Set selection1 = doc.selection
    selection1.Clear

    Dim selection2 As selection
    Set selection2 = doc.selection
    selection2.Clear
    
    Dim msg As String
    msg = "[selection1 - " & selection1.count & _
        "] [selection2 - " & selection2.count & "]"

    MsgBox msg

    selection1.Add pt.OriginElements.PlaneXY

    msg = "[selection1 - " & selection1.count & _
        "] [selection2 - " & selection2.count & "]"

    MsgBox msg

End Sub

Create selection1 and selection2 and display the number of selections made.
You will notice that the count for selection2 also changes, even though it was only added to selection1.
Selection refers to a single object even though it is assigned to multiple variables.

 

[kantoku]

I have created a sample that creates a midpoint without using "selection.Search".

'vba

Option Explicit

Sub CATMain()

    Dim msg As String
    msg = "Select a GeometrySet with curves to create midpoints / ESC = Cancel"
    
    Dim selElement As SelectedElement
    Set selElement = select_element( _
        msg, _
        Array("HybridBody") _
    )
    If selElement Is Nothing Then Exit Sub

    Call create_mid_points_from_geoSet( _
        selElement.value, _
        "Inspection Points" _
    )
    
    MsgBox "Done"

End Sub


Private Function create_mid_points_from_geoSet( _
    ByVal targetHBody As HybridBody, _
    ByVal name As String) _
    As HybridBody

    Set create_mid_points_from_geoSet = Nothing

    Dim targetCurves As Collection
    Set targetCurves = get_curves(targetHBody)
    If targetCurves.count < 1 Then
        Exit Function
    End If

    Dim pt As Part
    Set pt = get_parent_of_T(targetHBody, "Part")
    
    Dim resultHBody As HybridBody
    Set resultHBody = pt.HybridBodies.Add()
    resultHBody.name = name

    Dim crv As AnyObject
    For Each crv In targetCurves
        create_mid_point_by_curve crv, resultHBody
    Next

    pt.UpdateObject resultHBody

End Function


Private Sub create_mid_point_by_curve( _
    ByVal crv As AnyObject, _
    ByRef hBody As HybridBody)

    Dim pt As Part
    Set pt = get_parent_of_T(crv, "Part")

    Dim ref As reference
    Set ref = pt.CreateReferenceFromObject(crv)

    Dim fact As HybridShapeFactory
    Set fact = pt.HybridShapeFactory

    Dim pnt As HybridShapePointOnCurve
    Set pnt = fact.AddNewPointOnCurveFromPercent( _
        ref, _
        0.5, _
        False _
    )

    hBody.AppendHybridShape pnt

End Sub


Private Function get_curves( _
    ByVal hBody As HybridBody) _
    As Collection

    Dim pt As Part
    Set pt = get_parent_of_T(hBody, "Part")

    Dim fact As HybridShapeFactory
    Set fact = pt.HybridShapeFactory

    Dim crvs As Collection
    Set crvs = New Collection

    Dim shape As HybridShape
    Dim geoType As Long
    For Each shape In hBody.HybridShapes
        If fact.GetGeometricalFeatureType(shape) = 2 Then
            crvs.Add shape
        End If
    Next
    
    Set get_curves = crvs
    
End Function


Private Function get_parent_of_T( _
    ByVal aoj As AnyObject, _
    ByVal t As String) _
    As AnyObject
    
    Dim aojName As String
    Dim parentName As String
    
    On Error Resume Next
        aojName = aoj.name
        parentName = aoj.Parent.name
    On Error GoTo 0

    If TypeName(aoj) = TypeName(aoj.Parent) And _
       aojName = parentName Then
        Set get_parent_of_T = Nothing
        Exit Function
    End If
    If TypeName(aoj) = t Then
        Set get_parent_of_T = aoj
    Else
        Set get_parent_of_T = get_parent_of_T(aoj.Parent, t)
    End If

End Function


Private Function select_element( _
    ByVal msg As String, _
    ByVal filter As Variant _
    ) As SelectedElement
    
    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.selection

    sel.Clear
    Select Case sel.SelectElement2(filter, msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set select_element = sel.Item(1)
    sel.Clear

End Function

 

[CAD_ROB]

Hi Kantoku, Thanks for your reply.

When running the sample it runs through the mesg box, I select the geoset with the lines/circles in it and nothing happens. The msg box appears then wanting you to select done. Is this because it doesnt recognise the lines/circles as curves? This is when running through as VB script.

when running as a Catscript macro it errors on this line. "Set crvs = New Collection"

Just trying to understand the build up of this vb code.

 

[kantoku]

CAD_ROB.

I have never worked on CatScript, so I did not know the difference between VBA and CatScript.
・Collection is not available
・Return value of HybridShapeFactory.GetGeometricalFeatureType method is off by one.

'catscript

Option Explicit

Sub CATMain()

    Dim msg As String
    msg = "Select a GeometrySet with curves to create midpoints / ESC = Cancel"
    
    Dim selElement As SelectedElement
    Set selElement = select_element( _
        msg, _
        Array("HybridBody") _
    )
    If selElement Is Nothing Then Exit Sub

    Call create_mid_points_from_geoSet( _
        selElement.value, _
        "Inspection Points" _
    )
    
    get_curves selElement.value
    
    MsgBox "Done"

End Sub


Private Function create_mid_points_from_geoSet( _
    ByVal targetHBody As HybridBody, _
    ByVal name As String) _
    As HybridBody

    Set create_mid_points_from_geoSet = Nothing

    Dim targetCurves As Variant
    targetCurves = get_curves(targetHBody)
    If UBound(targetCurves) < 1 Then
        Exit Function
    End If

    Dim pt As Part
    Set pt = get_parent_of_T(targetHBody, "Part")
    
    Dim resultHBody As HybridBody
    Set resultHBody = pt.HybridBodies.Add()
    resultHBody.name = name

    Dim crv As AnyObject
    For Each crv In targetCurves
        create_mid_point_by_curve crv, resultHBody
    Next

    pt.UpdateObject resultHBody

End Function


Private Sub create_mid_point_by_curve( _
    ByVal crv As AnyObject, _
    ByRef hBody As HybridBody)

    Dim pt As Part
    Set pt = get_parent_of_T(crv, "Part")

    Dim ref As Reference
    Set ref = pt.CreateReferenceFromObject(crv)

    Dim fact As HybridShapeFactory
    Set fact = pt.HybridShapeFactory

    Dim pnt As HybridShapePointOnCurve
    Set pnt = fact.AddNewPointOnCurveFromPercent( _
        ref, _
        0.5, _
        False _
    )

    hBody.AppendHybridShape pnt

End Sub


Private Function get_curves( _
    ByVal hBody As HybridBody) _
    As Variant

    Dim pt As Part
    Set pt = get_parent_of_T(hBody, "Part")

    Dim fact As HybridShapeFactory
    Set fact = pt.HybridShapeFactory

    Dim crvs() As Variant
    ReDim crvs(hBody.HybridShapes.count)
    Dim count As Long
    count = -1

    Dim shape As HybridShape
    Dim geoType As Long
    Dim i As Long
    For i = 1 To hBody.HybridShapes.count
        Set shape = hBody.HybridShapes.Item(i)
        If fact.GetGeometricalFeatureType(shape) = 3 Then
            count = count + 1
            Set crvs(count) = shape
        End If
    Next
    ReDim Preserve crvs(count)
    get_curves = crvs
    
End Function


Private Function get_parent_of_T( _
    ByVal aoj As AnyObject, _
    ByVal t As String) _
    As AnyObject
    
    Dim aojName As String
    Dim parentName As String
    
    On Error Resume Next
        aojName = aoj.name
        parentName = aoj.Parent.name
    On Error GoTo 0

    If TypeName(aoj) = TypeName(aoj.Parent) And _
       aojName = parentName Then
        Set get_parent_of_T = Nothing
        Exit Function
    End If
    If TypeName(aoj) = t Then
        Set get_parent_of_T = aoj
    Else
        Set get_parent_of_T = get_parent_of_T(aoj.Parent, t)
    End If

End Function


Private Function select_element( _
    ByVal msg As String, _
    ByVal filter As Variant _
    ) As SelectedElement
    
    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.Selection

    sel.Clear
    Select Case sel.SelectElement2(filter, msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set select_element = sel.Item(1)
    sel.Clear

End Function

CatScript is difficult to debug and difficult to develop, so I will not work on it in the future.

 

[CAD_ROB]

Hi Kantoku,

It works great recognising the lines and generating the midpoints but doesn't seem to recognise curves or circle geometry and thus doesn't create a mid point on those.

Ive tried debugging the code and it errors at " For Each crv In targetCurves" is this a catscript unable to read error?

TIA

 

[LWolf]

circles, lines and curves should be considered in the get_curves function... so, inside the get_curves add the other two types of curves (3 and 4)

For Each shape In hBody.HybridShapes
        If fact.GetGeometricalFeatureType(shape) = 2 Or fact.GetGeometricalFeatureType(shape) = 3 Or fact.GetGeometricalFeatureType(shape) = 4 Then
            crvs.Add shape
        End If
    Next

regards,
LWolf

 

[CAD_ROB]

Thanks Kantoku and LWolf works a treat.