C#ATIA

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

DMUスペースアナリシスのセッション2

こちらのh2さんのコメントで、非常にありがたい情報を頂きました。
DMUスペースアナリシスのセッション - C#ATIA

結論から書くと、当方は素のHD2で DMU スペース・アナリシス のライセンス無しですが
セクションの作成が出来ました。
恐らく、

  Set s = Sect.Export

の状態は、Partファイルをロード(オープンじゃない)した状態になっているのでは
無いかと思います。

折角なので、サンプルを作ってみました。
確かに高速で断面を大量に作ります。

'vba sample_GuideCurve_DMU_Sections_ver0.0.1  using-'KCL0.0.12'  by Kantoku
'DMUスペースアナリシスのセクション
'ガイドカーブ指定し、分割数を入力することで
'セクションパートをTreeにぶら下げた状態で終了します

Option Explicit

Const DeflutSplitCount = 3 '分割数デフォルト

Sub CATMain()

    'ドキュメントのチェック
    If Not CanExecute("ProductDocument") Then Exit Sub
    
    'ガイドライン選択
    Dim SelElm As SelectedElement
    Set SelElm = SelectGuideCurve()
    If SelElm Is Nothing Then Exit Sub

    '分割数
    Dim SplitCount As Long
    SplitCount = InputSplitCount(DeflutSplitCount)
    If SplitCount < 1 Then Exit Sub
    Dim Ratios As Collection
    Set Ratios = InitRange(SplitCount)
    
    'マトリックス
    Dim AryMat As Variant
    AryMat = GetMat3dLst(SelElm, Ratios)
    
    'プロダクト
    Dim Prod As Product
    Set Prod = CATIA.ActiveDocument.Product
    
    'セクションコレクション
    Dim Sects As Object 'Sections
    Set Sects = Prod.GetTechnologicalObject("Sections")
    
    'セクションパート
    Dim SectDocs As Collection
    Set SectDocs = GetSectionDoc(Sects, AryMat)
    
    'インポート先
    Dim IptProd As Product
    Set IptProd = Prod.Products.AddNewComponent("Product", "")
    
    'インポート
    Call InportDoc(IptProd, SectDocs)
    
    'セクション削除
    Call Sects.Remove(Sects.Count)
    
    MsgBox "Done"
    
End Sub

'セクションインポート
Private Sub InportDoc(ByRef Prod As Product, ByRef SectDocs As Collection)
    Dim ProdsVar As Variant
    Set ProdsVar = Prod.Products
    
    Dim Doc As PartDocument
    For Each Doc In SectDocs
        ProdsVar.AddComponent Doc.Product
    Next
End Sub

'セクション-PartDoc
Private Function GetSectionDoc(ByVal Sects As Object, _
                               ByVal AryMat As Variant) As Collection
    Dim Sect As Object 'Section
    Set Sect = InitSection(Sects)
    
    Dim Docs As Collection
    Set Docs = New Collection
    
    Dim i As Long
    For i = 0 To UBound(AryMat)
        Call Sect.SetPosition(AryMat(i))
        If Not Sect.IsEmpty Then
            Call Docs.Add(Sect.Export())
        End If
    Next
    Set GetSectionDoc = Docs
End Function

'Section OJ
Private Function InitSection(ByVal Sects As Object) As Object 'Section
    'セクション追加
    Call Sects.Add
    Dim Sect As Object 'Section
    Set Sect = Sects.Item(Sects.Count)
    
    'モード変更
    '0-catSectionBehaviorManual
    '1-catSectionBehaviorAutomatic
    '2-catSectionBehaviorFreeze
    Sect.Behavior = 1
    
    '0-without clipping  1-clipping
    Sect.CutMode = 0
    
    Set InitSection = Sect
End Function

'断面用マトリックス
Private Function GetMat3dLst(ByVal CrvElm As SelectedElement, _
                             ByVal Ratios As Collection) As Variant
    Dim Pt As Part
    Set Pt = KCL.GetParent_Of_T(CrvElm.value, "Part")
    
    Dim Pnt As Variant 'HybridShapePointOnCurve
    Set Pnt = InitCrvOnPnt(CrvElm)
    
    Dim Pln As Variant 'HybridShapePlaneNormal
    Set Pln = InitCrvOnPlane(CrvElm, Pnt)
    
    Dim Drt As HybridShapeDirection
    Set Drt = InitDirection(Pln, Pt)
    
    Dim ratio As RealParam
    Set ratio = Pnt.ratio
    
    Dim AryMat() As Variant
    ReDim AryMat(Ratios.Count - 1)
    
    Dim Mat(11) As Variant
    Dim Ary(3) As Variant
    
    Dim idx As Long
    idx = 0
    Dim v As Variant
    For Each v In Ratios
        ratio.value = v
        Call Pt.UpdateObject(Pnt)
        Call Pt.UpdateObject(Pln)
        Call Pt.UpdateObject(Drt)
        
        '0-2
        Call Pln.GetFirstAxis(Mat)
        
        '3-5
        Call Pln.GetSecondAxis(Ary)
        Mat(3) = Ary(0)
        Mat(4) = Ary(1)
        Mat(5) = Ary(2)
        
        '6-8
        Mat(6) = Drt.GetXVal
        Mat(7) = Drt.GetYVal
        Mat(8) = Drt.GetZVal
        
        '9-11
        Call Pnt.GetCoordinates(Ary)
        Mat(9) = Ary(0)
        Mat(10) = Ary(1)
        Mat(11) = Ary(2)
        
        AryMat(idx) = Mat
        idx = idx + 1
    Next
    
    GetMat3dLst = AryMat
    
    '削除
    Dim fact As HybridShapeFactory
    Set fact = Pt.HybridShapeFactory
    
    Call fact.DeleteObjectForDatum(Drt)
    Call fact.DeleteObjectForDatum(Pln)
    Call fact.DeleteObjectForDatum(Pnt)
End Function

'範囲
Private Function InitRange(ByVal Count As Long) As Collection
    Dim Lst As Collection
    Set Lst = New Collection
    
    Dim stp As Double
    stp = 1# / (Count + 1)
    
    Dim i As Long
    For i = 0 To Count + 1
        Lst.Add i * stp
    Next
    Set InitRange = Lst
End Function

'方向
Private Function InitDirection(ByVal Pln As HybridShapePlaneNormal, _
                               ByVal Pt As Part) _
                               As HybridShapeDirection
    Dim fact As HybridShapeFactory
    Set fact = Pt.HybridShapeFactory

    Dim Ref As Reference
    Set Ref = Pt.CreateReferenceFromObject(Pln)
    
    Dim Drt As HybridShapeDirection
    Set Drt = fact.AddNewDirection(Ref)
    
    Call Pt.UpdateObject(Drt)
    Set InitDirection = Drt
End Function

'平面
Private Function InitCrvOnPlane(ByVal CrvElm As SelectedElement, _
                                ByVal Pnt As HybridShapePointOnCurve) _
                                As HybridShapePlaneNormal
    Dim Pt As Part
    Set Pt = KCL.GetParent_Of_T(CrvElm.value, "Part")
    
    Dim fact As HybridShapeFactory
    Set fact = Pt.HybridShapeFactory

    Dim Ref As Reference
    Set Ref = Pt.CreateReferenceFromObject(Pnt)

    Dim Pln As HybridShapePlaneNormal
    Set Pln = fact.AddNewPlaneNormal(CrvElm.Reference, Ref)

    Call Pt.UpdateObject(Pln)
    Set InitCrvOnPlane = Pln
End Function

'点
Private Function InitCrvOnPnt(ByVal CrvElm As SelectedElement) _
                              As HybridShapePointOnCurve
    Dim Pt As Part
    Set Pt = KCL.GetParent_Of_T(CrvElm.value, "Part")
    
    Dim fact As HybridShapeFactory
    Set fact = Pt.HybridShapeFactory

    Dim Pnt As HybridShapePointOnCurve
    Set Pnt = fact.AddNewPointOnCurveFromPercent(CrvElm.Reference, 0, False)
    
    Call Pt.UpdateObject(Pnt)
    Set InitCrvOnPnt = Pnt
End Function

'入力
Private Function InputSplitCount(ByVal def As Long) As Long
    Dim msg As String
    Dim tmp As Variant
    
    msg = "分割数を指定してください / 空白で終了" & vbCrLf & "両端は作成します"
    Do
        tmp = InputBox(msg, , def)
        Select Case True
            Case tmp = vbNullString
                InputSplitCount = -1
                Exit Function
            Case IsNumeric(tmp)
                If tmp >= 1 Then
                    InputSplitCount = CLng(tmp)
                    Exit Function
                End If
        End Select
        MsgBox "1以上の数字を入力して下さい", vbOKOnly + vbExclamation
    Loop
End Function

'ガイドライン選択
Private Function SelectGuideCurve() As SelectedElement
    Set SelectGuideCurve = Nothing
    Dim msg$
    msg = "ガイドラインを選択してください : ESCキー 終了"
    
    Dim SelElm As SelectedElement
    Dim Pt As Part
    
    Dim fact As HybridShapeFactory
    Dim Hs As HybridShape
    Do
        Set SelElm = KCL.SelectElement(msg, "HybridShape")
        If SelElm Is Nothing Then Exit Function
        
        Set Hs = SelElm.value
        Set Pt = KCL.GetParent_Of_T(Hs, "Part")
        Set fact = Pt.HybridShapeFactory
        Select Case fact.GetGeometricalFeatureType(SelElm.Reference)
            Case 2, 3, 4
                Set SelectGuideCurve = SelElm
                Exit Function
            Case Else
                MsgBox "直線,円弧,曲線 を選択してください"
        End Select
    Loop
End Function

ガイドラインを指定しラインの分割数を入力する事で分割数 + 始点 + 終点 分の
断面のCATPartをSubAssy状態でぶら下げて終了します。

実際にテストした感じです。

imihitoさん、h2さん の情報無しではここまで出来ませんでしたよ。
非常に感謝しております。
ライセンス無しでも出来る事が、少しはあるものですね。