C#ATIA

↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)

リンク付きDrawの丸の座標を取得する

CATIA V5です。こちらに挑戦しました。
Find the circle - DASSAULT: CATIA products - Eng-Tips

リンク付きDrawの丸い形状の中心座標を取得したいとの事ですが、
3Dのリンク付きのビューからは取得する事が出来ません。
これは手動で検索しても実感できます。

但し、リンクを分離すれば単なる線になる為、座標値の取得が可能です。
つまりビューをコピペし、分離し必要な情報を取得した後にコピペした
ビューを削除すれば良いのです。・・・Little Cthulhu氏、知っているくせに。

'vba

Option Explicit

Sub CATMain()

    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument

    Dim msg As String
    msg = "Select the view from which to extract the coordinates of the hole / ESC = Cancel"

    Dim selElement As SelectedElement
    Set selElement = select_element( _
        msg, _
        Array("DrawingView") _
    )
    If selElement Is Nothing Then Exit Sub

    Dim view As DrawingView
    Set view = selElement.value

    Dim cloneView As DrawingView
    Set cloneView = get_clone_view(view)
    '
    Dim circles As Collection
    Set circles = get_circles(cloneView)
    If circles Is Nothing Then
        remove_entity cloneView
        Exit Sub
    End If

    Dim groupRadius As Object
    Set groupRadius = group_by_radius(circles)

    remove_entity cloneView

    Call dump_circle_info( _
        dDoc.sheets.ActiveSheet, _
        "coordinate by " & view.name, _
        groupRadius _
    )
    
    MsgBox "Done"

End Sub


Private Function dump_circle_info( _
    ByVal sheet As DrawingSheet, _
    ByVal viewName As String, _
    ByVal dict As Object)

    Dim numericKeys As Variant
    numericKeys = quick_sort(get_numeric_keys(dict))

    Dim coordinateView As DrawingView
    Set coordinateView = create_view( _
        sheet, _
        viewName _
    )
    
    Dim a
    Dim txt As DrawingText
    Dim idx As Long
    Dim coordinates As Collection
    Dim coord As Collection
    Dim infoLst As Collection
    For idx = 0 To UBound(numericKeys)
        Set infoLst = New Collection
        infoLst.Add " ** diameter:" & numericKeys(idx) & " **"
        infoLst.Add "- posX,posY -"
        Set coordinates = dict.Item(Trim(Str(numericKeys(idx))))
        For Each coord In coordinates
            infoLst.Add Join(col2ary(coord), ",")
        Next
        
        Set txt = coordinateView.texts.Add( _
            Join(col2ary(infoLst), vbCrLf), _
            idx * 100, _
            0 _
        )
    Next

End Function


Private Function get_numeric_keys( _
    ByVal dict As Object) _
    As Variant
    
    Dim numericKeys() As Variant
    ReDim numericKeys(dict.count - 1)

    Dim ary As Variant
    ary = dict.keys

    Dim i As Long
    For i = 0 To dict.count - 1
      numericKeys(i) = CDbl(ary(i))
    Next

    get_numeric_keys = numericKeys

End Function


Private Function create_view( _
    ByVal sheet As DrawingSheet, _
    Optional ByVal name As String = vbNullString) _
    As DrawingView

    If name = vbNullString Then
        name = "AutomaticNaming"
    End If

    Set create_view = sheet.views.Add(name)

End Function


Private Function group_by_radius( _
    ByVal circles As Collection, _
    Optional ByVal roundTolerance As Long = 3) _
    As Object 'dict

    Dim group As Object
    Set group = init_dict()

    Dim values As Collection

    Dim center(1) As Variant
    Dim dia As Double
    Dim key As String
    Dim c As Variant ' Circle2D
    For Each c In circles
        dia = Round(c.radius * 2, roundTolerance)
        Call c.GetCenter(center)
        key = Trim(Str(dia))

        If group.Exists(key) Then
            group.Item(key).Add ary2col(center)
        Else
            Set values = New Collection
            values.Add ary2col(center)
            group.Add key, values
        End If
    Next

    Set group_by_radius = group

End Function


Private Function col2ary( _
    ByVal col As Collection) _
    As Variant

    Dim ary() As Variant
    ReDim ary(col.count - 1)

    Dim i As Long
    For i = 1 To col.count
        ary(i - 1) = col.Item(i)
    Next

    col2ary = ary

End Function


Private Function ary2col( _
    ByVal ary As Variant) _
    As Collection

    Dim col As Collection
    Set col = New Collection

    Dim i As Long
    For i = 0 To UBound(ary)
        col.Add ary(i)
    Next

    Set ary2col = col

End Function


Private Sub remove_entity( _
    entity As AnyObject)
    
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection

    CATIA.HSOSynchronized = False

    With sel
        .Clear
        .Add entity
        .Delete
    End With

    CATIA.HSOSynchronized = True
    
End Sub


Private Function get_circles( _
    ByVal view As DrawingView) _
    As Collection

    Set get_circles = Nothing

    Dim sheet As DrawingSheet
    Set sheet = get_parent_of_T(view, "DrawingSheet")

    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection

    CATIA.HSOSynchronized = False

    With sel
        .Clear
        .Add view
        .Search "CATDrwSearch.2DCircle,sel"
    End With

    If sel.Count2 < 1 Then
        CATIA.HSOSynchronized = True
        Exit Function
    End If

    Dim circles As Collection
    Set circles = New Collection

    Dim i As Long
    For i = 1 To sel.Count2
        circles.Add sel.Item2(i).value
    Next
        
    sel.Clear

    CATIA.HSOSynchronized = True
    
    Set get_circles = circles

End Function


Private Function get_clone_view( _
    ByVal view As DrawingView) _
    As DrawingView

    Dim sheet As DrawingSheet
    Set sheet = get_parent_of_T(view, "DrawingSheet")

    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection

    CATIA.HSOSynchronized = False

    With sel
        .Clear
        .Add view
        .Copy
        .Clear

        .Add sheet
        .Paste
    End With

    Dim tempView As DrawingView
    Set tempView = sel.Item2(1).value

    sel.Clear

    CATIA.HSOSynchronized = True

    tempView.LockStatus = False
    tempView.Isolate

    Set get_clone_view = tempView

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 init_dict( _
    Optional CompareMode As Long = vbBinaryCompare) _
    As Object

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = CompareMode
    Set init_dict = dict

End Function


Private Function quick_sort( _
    ByVal ary As Variant) As Variant

    If IsEmpty(ary) Then
        quick_sort = Empty
        Exit Function
    End If

    Dim stack As Object
    Set stack = init_dict()
   
    Dim leftIdx As Long
    Dim rightIdx As Long
    Dim pivot As Variant
    Dim tPivot(2) As Variant
    Dim temp As Variant
   
    Dim i As Long
    Dim j As Long
    stack.Add stack.count + 1, LBound(ary)
    stack.Add stack.count + 1, UBound(ary)
    Do While stack.count > 0
               
        leftIdx = stack(stack.count - 1)
        rightIdx = stack(stack.count)
        stack.Remove stack.count
        stack.Remove stack.count

        If leftIdx < rightIdx Then
       
            pivot = ary((leftIdx + rightIdx) / 2)
           
            i = leftIdx
            j = rightIdx
           
            Do While i <= j
           
                Do While ary(i) < pivot
                    i = i + 1
                Loop
           
                Do While ary(j) > pivot
                    j = j - 1
                Loop
           
                If i <= j Then
                    temp = ary(i)
                    ary(i) = ary(j)
                    ary(j) = temp
                   
                    i = i + 1
                    j = j - 1
                End If
           
            Loop
           
            If rightIdx - i >= 0 Then
                If rightIdx - i <= 10 Then
                    insertion_sort ary, i, rightIdx
                Else
                    stack.Add stack.count + 1, i
                    stack.Add stack.count + 1, rightIdx
                End If
            End If
           
            If j - leftIdx >= 0 Then
                If j * leftIdx <= 10 Then
                    insertion_sort ary, leftIdx, j
                Else
                    stack.Add stack.count + 1, leftIdx
                    stack.Add stack.count + 1, j
                End If
            End If
        End If
   
    Loop

    quick_sort = ary
End Function


Private Function insertion_sort( _
    ary As Variant, _
    minIdx As Long, _
    maxIdx As Long)

    Dim i As Long, j As Long
    Dim temp As Variant
    j = 1
    For j = minIdx To maxIdx
        i = j - 1
        Do While i >= 0
            If ary(i + 1) < ary(i) Then
                temp = ary(i + 1)
                ary(i + 1) = ary(i)
                ary(i) = temp
            Else
                Exit Do
            End If
            i = i - 1
        Loop
    Next
    
    insertion_sort = ary
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 

ヘビーでした。
直径をキー、中心座標のコレクションを値としたDictを作っています。
最後は直径でソートして出力しているのですが、結果を出力させている
dump_circle_info関数の汚い事。

本来はテーブルで出力させようと思ったのですが、面倒になり力付きました。

CSVをインポートする機能がマクロで使えるのか分かりませんが、
使えるのであれば、CSV出力→インポートが楽だとは思いますが。