こちらの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さん の情報無しではここまで出来ませんでしたよ。
非常に感謝しております。
ライセンス無しでも出来る事が、少しはあるものですね。