Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
'vba
Option Explicit
Private Const TOLERANCE = 0.001
Sub CATMain()
Dim partDoc As PartDocument
Set partDoc = CATIA.ActiveDocument
Dim msg As String
msg = "Please select a reference edge or line : ESC key Exit"
Dim filter As Variant
filter = Array( _
"RectilinearTriDimFeatEdge", _
"RectilinearBiDimFeatEdge", _
"RectilinearMonoDimFeatEdge" _
)
Dim baseLineRef As Reference
Set baseLineRef = select_item_reference(msg, filter)
If baseLineRef Is Nothing Then Exit Sub
msg = "Please select a geometric set to find perpendicular edges : ESC key Exit"
filter = Array("HybridBody")
Dim hBody As HybridBody
Set hBody = select_item(msg, filter)
If hBody Is Nothing Then Exit Sub
Dim edges As Collection
Set edges = get_perpendicular_edges(baseLineRef, hBody)
Dim sel As Selection
Set sel = partDoc.Selection
sel.Clear
Dim edge As Reference
For Each edge In edges
sel.Add edge
Next
MsgBox "Done"
End Sub
Private Function get_perpendicular_edges( _
ByVal baseLineRef As Reference, _
ByVal hBody As HybridBody _
) As Collection
Dim edges As Collection
Set edges = get_edges(hBody)
If edges.count < 1 Then
Set get_perpendicular_edges = edges
Exit Function
End If
Dim pt As Part
Set pt = get_parent_of_T(hBody, "Part")
Dim meas As Measurable
Set meas = get_measurable( _
pt, _
baseLineRef _
)
Dim perpendicularEdges As Collection
Set perpendicularEdges = New Collection
Dim edge As Reference
For Each edge In edges
On Error Resume Next
If Abs(meas.GetAngleBetween(edge) - 90) < TOLERANCE Then
perpendicularEdges.Add edge
End If
On Error GoTo 0
Next
Set get_perpendicular_edges = perpendicularEdges
End Function
Private Function get_edges( _
ByVal hBody As HybridBody _
) As Collection
Dim partDoc As PartDocument
Set partDoc = get_parent_of_T(hBody, "PartDocument")
Dim sel As Selection
Set sel = partDoc.Selection
CATIA.HSOSynchronized = False
With sel
.Clear
.Add hBody
.Search "Topology.CGMEdge,sel"
End With
Dim edges As Collection
Set edges = New Collection
Dim i As Long
For i = 1 To sel.Count2
edges.Add sel.Item2(i).Reference
Next
sel.Clear
CATIA.HSOSynchronized = True
Set get_edges = edges
End Function
Private Function get_measurable( _
ByVal pt As Part, _
ByVal ref As Reference _
) As Measurable
Dim wb, meas As Measurable
Set wb = pt.Parent.GetWorkbench("SPAWorkbench")
Set get_measurable = wb.GetMeasurable(ref)
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_item( _
ByVal msg As String, _
ByVal filter As Variant _
) As AnyObject
Dim res As SelectedElement
Set res = select_element(msg, filter)
If res Is Nothing Then
Set select_item = Nothing
Else
Set select_item = res.value
End If
End Function
Private Function select_item_reference( _
ByVal msg As String, _
ByVal filter As Variant _
) As Reference
Dim res As SelectedElement
Set res = select_element(msg, filter)
If res Is Nothing Then
Set select_item_reference = Nothing
Else
Set select_item_reference = res.Reference
End If
End Function
Private Function select_element( _
ByVal msg As String, _
ByVal filter As Variant _
) As SelectedElement
Set select_element = Nothing
Dim sel As Variant 'Selection
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.Item2(1)
End Function