ボディの体積をダンプする5

中途半端な状態で止まっていましたが、やっと取り組めました。

・CATIAの場合、体積が単純なプロパティでは取得出来ない
・VBAのクラスに拡張プロパティのような考えが無い
を考慮すると、

ソート関数(ソート対象の配列, 比較のための配列)

のような関数を作る事にしました。

'vba

Option Explicit

Sub CATMain()

    Dim doc As partDocument
    Set doc = CATIA.ActiveDocument
    
    Dim pt As Part
    Set pt = doc.Part

    'ボディを配列として取得
    Dim bodyAry As Variant
    bodyAry = get_bodies_array(pt.bodies)

    '体積配列を取得 - ボディの配列のインデックスと一致
    Dim volumeAry As Variant
    volumeAry = get_bodies_volume(bodyAry)

    '確認
    dump_pair bodyAry, volumeAry, "-- ソート前 --"

    'ソート
    Dim sortedBodyAry As Variant
    sortedBodyAry = insertion_sort(bodyAry, volumeAry)

    'ソート後の体積配列取得
    volumeAry = get_bodies_volume(sortedBodyAry)

    '確認
    dump_pair sortedBodyAry, volumeAry, vbCrLf & "-- ソート後 --"

End Sub


Private Function insertion_sort( _
    ByVal targetAry As Variant, _
    ByVal comparisonAry As Variant _
) As Variant

    Dim zip() As Variant
    zip = zip_array(targetAry, comparisonAry)

    Dim low As Long
    low = LBound(zip)

    Dim upp As Long
    upp = UBound(zip)

    Dim i As Long, j As Long
    Dim tmp As Variant
    For i = low + 1 To upp
        tmp = zip(i)
        For j = i - 1 To low Step -1
            If zip(j)(1) > tmp(1) Then
                zip(j + 1) = zip(j)
            Else
                Exit For
            End If
        Next
        zip(j + 1) = tmp
    Next

    Dim unzip() As Variant
    unzip = unzip_array(zip)
    
    insertion_sort = unzip(0)
    
End Function


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

    Dim ary1() As Variant
    ary1 = create_array(UBound(ary))

    Dim ary2() As Variant
    ary2 = create_array(UBound(ary))

    Dim i As Long
    For i = 0 To UBound(ary)
        Set ary1(i) = ary(i)(0)
        ary2(i) = ary(i)(1)
    Next

    unzip_array = Array(ary1, ary2)

End Function


Private Function zip_array( _
    ByVal ary1 As Variant, _
    ByVal ary2 As Variant _
) As Variant

    Dim zip() As Variant
    zip = create_array(UBound(ary1))

    Dim i As Long
    For i = 0 To UBound(ary1)
        zip(i) = Array(ary1(i), ary2(i))
    Next

    zip_array = zip

End Function


Private Function create_array( _
    count As Long _
) As Variant

    Dim ary() As Variant
    ReDim ary(count)

    create_array = ary

End Function


Private Function get_bodies_volume( _
    ByVal bodyAry As Variant) _
As Variant

    get_bodies_volume = Array()

    If UBound(bodyAry) < 1 Then Exit Function

    Dim pt As Part
    Set pt = get_parent_of_T(bodyAry(0), "Part")

    Dim volumeAry() As Variant
    volumeAry = create_array(UBound(bodyAry))

    Dim spaWb As SPAWorkbench
    Set spaWb = pt.Parent.GetWorkbench("SPAWorkbench")

    Dim bdy As Body
    Dim bodyRef As Reference
    Dim meas As Measurable
    Dim shape As AnyObject
    Dim volume As Double
    Dim i As Long
    For i = 0 To UBound(bodyAry)
        Set bdy = bodyAry(i)
        Set shape = get_last_shape(bdy)
        If shape Is Nothing Then
            volume = 0
        Else
            Set bodyRef = pt.CreateReferenceFromObject(shape)
            Set meas = spaWb.GetMeasurable(bodyRef)
            volume = meas.volume
        End If

        volumeAry(i) = volume
    Next

    get_bodies_volume = volumeAry

End Function


Private Function get_bodies_array( _
    ByVal bodyLst As bodies) _
As Variant

    Dim ary() As Variant
    ary = create_array(bodyLst.count - 1)

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

    get_bodies_array = ary

End Function


Private Function get_last_shape( _
    ByVal bdy As Body) _
    As AnyObject

    Set get_last_shape = Nothing

    If bdy.shapes.count < 1 Then Exit Function

    Dim pt As Part
    Set pt = get_parent_of_T(bdy, "Part")
    
    Dim shapes As shapes
    Set shapes = bdy.shapes
    
    Dim i As Long
    For i = shapes.count To 1 Step -1
        If Not IsEmpty(shapes.Item(i)) Then
            If False = pt.IsInactive(shapes.Item(i)) Then
                Set get_last_shape = shapes.Item(i)
                Exit Function
            End If
        End If
    Next
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
        Set aoj = asDisp(aoj)
        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 asDisp( _
    o As INFITF.CATBaseDispatch) _
    As INFITF.CATBaseDispatch

    Set asDisp = o
End Function


Private Sub dump_pair( _
    ByVal bodyAry As Variant, _
    ByVal volumeAry As Variant, _
    Optional ByVal msg = "")

    dump msg

    Dim i As Long
    For i = 0 To UBound(bodyAry)
        dump bodyAry(i).name & " : " & Format(volumeAry(i), "0.00000000000000000000000")
    Next
End Sub


Private Sub dump( _
    ByVal msg As String)
    
    Debug.Print msg
End Sub

試しにこの様な適当なデータを作成し実行してみます。

結果はこちら。一応出来ています。

-- ソート前 --
ﾊﾟｰﾂ ﾎﾞﾃﾞｨｰ : 0.00077597338543667900000
ﾎﾞﾃﾞｨｰ.3 : 0.00026000000000000000000
ﾎﾞﾃﾞｨｰ.4 : 0.00056500000000000000000
ﾎﾞﾃﾞｨｰ.5 : 0.00006338919271492180000
ﾎﾞﾃﾞｨｰ.6 : 0.00000031415926535897900

-- ソート後 --
ﾎﾞﾃﾞｨｰ.6 : 0.00000031415926535897900
ﾎﾞﾃﾞｨｰ.5 : 0.00006338919271492180000
ﾎﾞﾃﾞｨｰ.3 : 0.00026000000000000000000
ﾎﾞﾃﾞｨｰ.4 : 0.00056500000000000000000
ﾊﾟｰﾂ ﾎﾞﾃﾞｨｰ : 0.00077597338543667900000

・・・指数表記だとパッと見で判断しにくかったですが、
どうやるのが良いのだろう？

これ、安全か？　と言われるとちょっと例外処理やら、
配列の先頭のインデックスの判断とか、zipライクな関数で
二つの配列サイズが未チェックだとか省いているので、
ちょっと怪しいです。

仮に、体積ではなく表面積にしたいのであれば、
insertion_sort関数の第二引数の配列を変更すれば良いので、
多少は柔軟性を持っているはず。

クイックソートで無いのですが、CATIAでソートが必要になる場面は
それ程大きいサイズにならないと思うので、大丈夫じゃないかな？

C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

ボディの体積をダンプする5