ThickOnTheFly2

こちらの続き？　です。
ThickOnTheFly1 - C#ATIA
こちら作りかけて止めました。続けてもいないのですがｺｰﾄﾞを
記載していなかったので････。
正直な所、変数・関数名等が酷いのですが、直す気力がありません。

'vba using-'KCL0.0.12'
'動的にﾎﾞﾃﾞｨの厚みをStatusBarに表示させる
'厚み解析のｱﾙｺﾞﾘｽﾞﾑ自体が正しくないです

Private Const MaxLng = 2000000#
Private Const MinLng = 0.002

Sub CATMain()
    Dim Sel 'As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    Dim Pt As Part
    Set Pt = CATIA.ActiveDocument.Part
    Dim PlaneXY As AnyObject
    Set PlaneXY = Pt.OriginElements.PlaneXY
    Dim fact As HybridShapeFactory
    Set fact = Pt.HybridShapeFactory
    
    Dim Status 'As Long
    Dim WindowLocation2D(1)
    Dim WindowLocation3D(2)
    Dim ObjectSelected
    
    Dim Hb As HybridBody
    Set Hb = Pt.hybridBodies.Add
    
    'ﾊﾟｰﾂﾎﾞﾃﾞｨ
    Dim Bd As Body
    
    Set Bd = KCL.SelectItem("body", "Body")
    
    'ﾊﾟｰﾂﾎﾞﾃﾞｨの最後のﾊﾟｰﾄﾃﾞｻﾞｲﾝﾌｭｰﾁｬｰ
    Dim LastShape As Shape
    Set LastShape = Bd.Shapes.Item(Bd.Shapes.Count)
    
    'ﾌｭｰﾁｬｰのﾘﾌｧﾚﾝｽ
    Dim RefShape As Reference
    Set RefShape = Pt.CreateReferenceFromGeometry(LastShape)
    
    Dim ShapeSrf As HybridShape: Set ShapeSrf = CreateExtract(Pt, fact, RefShape)
    Dim RefShapeSrf As Reference: Set RefShapeSrf = Pt.CreateReferenceFromGeometry(ShapeSrf)
    
    'ｶｰｿﾙがﾎﾞﾃﾞｨ上?
    Dim OnBdyLst As Collection: Set OnBdyLst = New Collection
    
    '原点
    Dim ori As HybridShape: Set ori = CreatePnt(Pt, fact, Array(0#, 0#, 0#))
    Call Pt.UpdateObject(ori)
    Dim RefOri As Reference: Set RefOri = Pt.CreateReferenceFromGeometry(ori)
    
    Dim PntCam As HybridShape: Set PntCam = CreatePnt(Pt, fact, Array(0#, 0#, 0#))
    Dim RefCam As Reference: Set RefCam = Pt.CreateReferenceFromGeometry(PntCam)
    
    'ﾏｳｽｶｰｿﾙ3D位置
    Dim PntTgt As HybridShape: Set PntTgt = CreatePnt(Pt, fact, Array(0#, 0#, 1#))
    Dim RefTgt As Reference: Set RefTgt = Pt.CreateReferenceFromGeometry(PntTgt)
    
    'ｶﾒﾗ方向単位ﾍﾞｸﾄﾙ
    Dim CamUnitVec As HybridShape: Set CamUnitVec = CreatePnt(Pt, fact, Array(0#, 0#, 1#))
    Dim RefCamUnitVec As Reference: Set RefCamUnitVec = Pt.CreateReferenceFromGeometry(CamUnitVec)
    
    'ｶﾒﾗ方向用単位線
    Dim UnitLin As HybridShape: Set UnitLin = CreateLine(Pt, fact, RefOri, RefCamUnitVec, 0#, 0#)
    Dim RefUnitLin As Reference: Set RefUnitLin = Pt.CreateReferenceFromGeometry(UnitLin)
    Call OnBdyLst.Add(UnitLin)
    
    'ｶﾒﾗ方向
    Dim CamVec As HybridShape: Set CamVec = CreateDirection(fact, RefUnitLin)
    Dim RefCamVec As Reference: Set RefCamVec = Pt.CreateReferenceFromGeometry(CamVec)
    Call OnBdyLst.Add(CamVec)
    
    Dim LinVew As HybridShape: Set LinVew = CreateExtrude(fact, RefTgt, CamVec, MaxLng, MaxLng)
    Dim RefVew As Reference: Set RefVew = Pt.CreateReferenceFromGeometry(LinVew)
    Call OnBdyLst.Add(LinVew)
    
    Dim Isc As HybridShape: Set Isc = GetIntersect(fact, RefShapeSrf, RefVew)
    Dim RefIsc As Reference: Set RefIsc = Pt.CreateReferenceFromGeometry(Isc)
    Call OnBdyLst.Add(Isc)
    
    Dim Near As HybridShape: Set Near = GetNear(fact, RefIsc, RefCam)
    Dim RefNer As Reference: Set RefNer = Pt.CreateReferenceFromGeometry(Near)
    Call OnBdyLst.Add(Near)
    Hb.AppendHybridShape Near: Call SetColor(Near)
    
    Dim Rev As Boolean: Rev = True 'これいらないかも
    Dim Nml As HybridShape: Set Nml = CreateNormal(fact, RefShapeSrf, RefNer, MinLng, MaxLng, Rev)
    Dim RefNml As Reference: Set RefNml = Pt.CreateReferenceFromGeometry(Nml)
    Call OnBdyLst.Add(Nml)
    
    'Nml.Pointｴﾗｰ対策
    Dim NmlPnt As HybridShapePointOnCurve: Set NmlPnt = CreatePntOnCrv(fact, RefNml, 0#, Rev) '***********
    Dim RefNmlPnt As Reference: Set RefNmlPnt = Pt.CreateReferenceFromGeometry(NmlPnt)
    Call OnBdyLst.Add(NmlPnt)
    
    '厚さﾘｽﾄ
    Dim ThickLst As Collection: Set ThickLst = New Collection
    
    Dim ThkIsc As HybridShape: Set ThkIsc = GetIntersect(fact, RefShapeSrf, RefNml)
    Dim RefThkIsc As Reference: Set RefThkIsc = Pt.CreateReferenceFromGeometry(ThkIsc)
    Call ThickLst.Add(ThkIsc)
    
    Dim ThkPnt As HybridShape: Set ThkPnt = GetNear(fact, RefThkIsc, RefNer)
    Dim RefThkPnt As Reference: Set RefThkPnt = Pt.CreateReferenceFromGeometry(ThkPnt)
    Call ThickLst.Add(ThkPnt)
    Hb.AppendHybridShape ThkPnt: Call SetColor(ThkPnt)
    
    Dim vp As Variant ' Viewpoint3D
    Set vp = GetViewPnt3D
    Dim origin(2) As Variant:
    Dim sight(2) As Variant
    Dim Thi$: Thi = "0"
    
    Do
        Status = Sel.IndicateOrSelectElement3D(PlaneXY, "t=" & Thi, Array("HybridShapePointCoord"), True, True, True, ObjectSelected, WindowLocation2D, WindowLocation3D)

        Select Case Status
            Case "Cancel"
                Exit Do
            Case "Normal"
            
            Case "MouseMove"
                Call vp.GetOrigin(origin)
                Call UpdatePnt(Pt, PntCam, origin)
                Call UpdatePnt(Pt, PntTgt, WindowLocation3D)
                Call vp.GetSightDirection(sight)
                Call UpdatePnt(Pt, CamUnitVec, sight)
                If TryUpdate(Pt, OnBdyLst) Then
                    Debug.Print GetMinLng(Pt, RefShape, RefNmlPnt)
                    If Not GetMinLng(Pt, RefShape, RefNmlPnt) = 0 Then
                        'Rev
                        Nml.Orientation = IIf(Nml.Orientation = 1, -1, 1)
                        Call Pt.UpdateObject(Nml)
                        NmlPnt.Orientation = Nml.Orientation
                        Call Pt.UpdateObject(NmlPnt)
                    End If
                    If TryUpdate(Pt, ThickLst) Then
                        Thi = CStr(GetMinLng(Pt, RefNer, RefThkPnt))
                    End If
                End If
        End Select
    Loop
End Sub

Private Sub SetColor(ByVal Shp As AnyObject)
    With CATIA.ActiveDocument.Selection
        .Clear
        .Add Shp
        .VisProperties.SetRealColor 0, 255, 0, 1
        .VisProperties.SetSymbolType 4
        .Clear
    End With
End Sub

Private Function CreateExtrude( _
                    ByVal fact As HybridShapeFactory, _
                    ByVal Ref As Reference, _
                    ByVal Dir As HybridShapeDirection, _
                    ByVal StLng As Double, _
                    ByVal EdLng As Double) As HybridShape
    Set CreateExtrude = fact.AddNewExtrude(Ref, StLng, EdLng, Dir)
End Function

Private Function CreateDirection( _
                    ByVal fact As HybridShapeFactory, _
                    ByVal Ref As Reference) As HybridShape
    Set CreateDirection = fact.AddNewDirection(Ref)
End Function

Private Function TryUpdate( _
                    ByVal Pt As Part, _
                    ByRef LstObj As Collection) As Boolean
    TryUpdate = False
    Dim Shp As HybridShape
    On Error Resume Next
        For Each Shp In LstObj
            Call Pt.UpdateObject(Shp)
            If Not Err.Number = 0 Then
                Err.Number = 0
                Exit Function
            End If
        Next
    On Error GoTo 0
    TryUpdate = True
End Function

'点-線上
Private Function CreatePntOnCrv( _
                    ByVal fact As HybridShapeFactory, _
                    ByVal CrvRef As Reference, _
                    ByVal Lng As Double, _
                    ByVal Rev As Boolean) As Reference
    Dim Pnt As HybridShapePointOnCurve
    Set Pnt = fact.AddNewPointOnCurveFromDistance(CrvRef, Lng, Rev)
    
    Set CreatePntOnCrv = Pnt
End Function

'法線
Private Function CreateNormal( _
                    ByVal fact As HybridShapeFactory, _
                    ByVal SurfRef As Reference, _
                    ByVal pntRef As Reference, _
                    ByVal SLng As Double, _
                    ByVal ELng As Double, _
                    ByVal Rev As Boolean) As Reference
    Dim Lin As HybridShapeLineNormal
    Set Lin = fact.AddNewLineNormal(SurfRef, pntRef, SLng, ELng, Rev)
    Set CreateNormal = Lin
End Function

'抽出
Private Function CreateExtract( _
                    ByVal Pt As Part, _
                    ByVal fact As HybridShapeFactory, _
                    ByVal Ref As Reference) As HybridShape
    Dim HSExt As HybridShapeExtract
    Set HSExt = fact.AddNewExtract(Ref)
    With HSExt
        .PropagationType = 3
        .ComplementaryExtract = False
        .IsFederated = False
    End With
    Call Pt.UpdateObject(HSExt)
    Set CreateExtract = HSExt
End Function

'近傍
Private Function GetNear( _
                    ByVal fact As HybridShapeFactory, _
                    ByVal InterRef As Reference, _
                    ByVal pntRef As Reference) ' As Reference
    Dim Near As HybridShapeNear
    Set Near = fact.AddNewNear(InterRef, pntRef)

    Set GetNear = Near
End Function

'交差
Private Function GetIntersect( _
                    ByVal fact As HybridShapeFactory, _
                    ByVal ShpRef As Reference, _
                    ByVal LinRef As Reference) ' As Reference
    Set GetIntersectRef = Nothing
    
    Dim Inter As HybridShapeIntersection
    Set Inter = fact.AddNewIntersection(ShpRef, LinRef)
    Inter.PointType = 0
    
    Set GetIntersect = Inter
End Function

'最短距離測定
Private Function GetMinLng( _
                    ByVal Pt As Part, _
                    ByVal Ref1 As Reference, _
                    ByVal Ref2 As Reference) As Double
    GetMinLng = MaxLng '-1
    On Error Resume Next
        GetMinLng = Pt.Parent.GetWorkbench("SPAWorkbench") _
                         .GetMeasurable(Ref1) _
                         .GetMinimumDistance(Ref2)
    On Error GoTo 0
End Function

Private Sub UpdatePnt( _
                    ByVal Pt As Part, _
                    ByRef Pnt As Variant, _
                    ByVal Pos As Variant)
    Call Pnt.SetCoordinates(Pos)
    Call Pt.UpdateObject(Pnt)
End Sub

'点
Private Function CreatePnt( _
                    ByVal Pt As Part, _
                    ByVal fact As HybridShapeFactory, _
                    ByVal Ary As Variant) As HybridShape
    Dim Pnt As HybridShapePointCoord
    Set Pnt = fact.AddNewPointCoord(Ary(0), Ary(1), Ary(2))
    Call Pt.UpdateObject(Pnt)
    Set CreatePnt = Pnt
End Function

Private Function CreateLine( _
                    ByVal Pt As Part, _
                    ByVal fact As HybridShapeFactory, _
                    ByVal Ref1 As Reference, _
                    ByVal Ref2 As Reference, _
                    ByVal StLng As Double, _
                    ByVal EdLng As Double) As HybridShape
    Dim Lin As HybridShapeLinePtPt
    Set Lin = fact.AddNewLinePtPtExtended(Ref1, Ref2, StLng, EdLng)
    Call Pt.UpdateObject(Lin)
    Set CreateLine = Lin
End Function

'表示のUpdate
Private Sub UpdateScene(ByVal Scene As Variant)
    Dim Viewer As Viewer3D: Set Viewer = CATIA.ActiveWindow.activeviewer
    Dim VPnt3D As Variant 'Viewpoint3D
    Set VPnt3D = Viewer.Viewpoint3D
    
    Dim Ary As Variant
    Ary = KCL.GetRangeAry(Scene, 0, 2)
    Call VPnt3D.PutOrigin(Ary)
    
    Ary = KCL.GetRangeAry(Scene, 3, 5)
    Call VPnt3D.PutSightDirection(Ary)
    
    Ary = KCL.GetRangeAry(Scene, 6, 8)
    Call VPnt3D.PutUpDirection(Ary)
    
    VPnt3D.FieldOfView = Scene(9)
    VPnt3D.FocusDistance = Scene(10)
    
    Call Viewer.Update
End Sub

'Viewpoint3Dからｼｰﾝ取得
Private Function GetScene3D(ViewPnt3D As Viewpoint3D) As Variant
    Dim vp As Variant: Set vp = ViewPnt3D
    
    Dim origin(2) As Variant: Call vp.GetOrigin(origin)
    
    Dim sight(2) As Variant: Call vp.GetSightDirection(sight)
    GetScene3D = KCL.JoinAry(origin, sight)
    
    Dim up(2) As Variant: Call vp.GetUpDirection(up)
    GetScene3D = KCL.JoinAry(GetScene3D, up)
    
    Dim FieldOfView(0) As Variant: FieldOfView(0) = vp.FieldOfView
    GetScene3D = KCL.JoinAry(GetScene3D, FieldOfView)
    
    Dim FocusDist(0) As Variant: FocusDist(0) = vp.FocusDistance
    GetScene3D = KCL.JoinAry(GetScene3D, FocusDist)
End Function

'現状の視点取得
Private Function GetViewPnt3D() As Viewpoint3D
    Set GetViewPnt3D = CATIA.ActiveWindow.activeviewer.Viewpoint3D
End Function

確か、一度XY平面を通過する位置にマウスを移動しないと、厚みが表示されなかった
記憶です。（奥行きの値を取得する為です）

最初に必要となるGSDの要素をHybridShapeFactoryで作り出し、
マウスを動かす度にUpdateしまくり、厚みを表示させています。
そのため、ﾁﾗﾂｷ感が酷いです。

「厚みを表示」と書いておりますが、算出方法が（少なくとも）2種類あり
こちらのサイトの "RAY法" になるのだと思います。
GeomCaliper | ジオムキャリパー | CATIA V5モデルの肉厚の測定と表示 | アイコクアルファ株式会社
本当は "Sphere法" を行いたいのですが、ｱﾙｺﾞﾘｽﾞﾑが良くわからないんです。
（測定対象となる相手の面さえ見つければ良いのですが、効率良く見つけ出す方法が
　わかりません）

・・・先日知ったのですが、海外の方もここを見て頂いているようでして、
3年ぐらい続けるとそんな事もあるんですね。

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さん　の情報無しではここまで出来ませんでしたよ。
非常に感謝しております。
ﾗｲｾﾝｽ無しでも出来る事が、少しはあるものですね。

DMUｽﾍﾟｰｽｱﾅﾘｼｽのｾｯｼｮﾝ

「DMUｽﾍﾟｰｽｱﾅﾘｼｽのｾｯｼｮﾝを利用して、多くの断面を取得したい」
と御相談を頂きました。
が、当方にはDMUｽﾍﾟｰｽｱﾅﾘｼｽのﾗｲｾﾝｽが無い為、手も足も出ないのが
本音なのですが、過去にこちらを試した事があったため
出来る限りのことは記載しておきます。
技術的なｵﾌﾞｼﾞｪｸﾄ？1 - C#ATIA

こんな感じのコードを作りました。

'vba
'DMUｽﾍﾟｰｽｱﾅﾘｼｽのｾｯｼｮﾝのﾃｽﾄ

Sub CATMain()
    'ﾌﾟﾛﾀﾞｸﾄ
    Dim Prod As Product
    Set Prod = CATIA.ActiveDocument.Product
    
    'ｾｸｼｮﾝｺﾚｸｼｮﾝ
    Dim Sects As Object 'Sections
    Set Sects = Prod.GetTechnologicalObject("Sections")
    
    'ｾｸｼｮﾝ追加
    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 = 1
    
    'ﾏﾄﾘｯｸｽ
    Dim Mat(11) As Variant ' Double
    Call Sect.GetPosition(Mat)
    
    Stop
    
    'ﾏﾄﾘｯｸｽ変更
    Mat(11) = Mat(11) + 1#
    Call Sect.SetPosition(Mat)

    'ｴｸｽﾎﾟｰﾄ
    '何処に何をｴｸｽﾎﾟｰﾄしているのか不明
    'Call Sec.Export

    Stop
End Sub

このﾏｸﾛを実行すると、ﾗｲｾﾝｽが無いにも関わらずTree部分に
ｾｸｼｮﾝが残ります。（使い道は無いのですが）

Exportが全くの謎で、ﾗｲｾﾝｽがあれば可能だと思うのですが
手動操作も良くわかっていないため、この辺が限界です。

SetPositionで断面位置調節し、Exportをｼﾞｬﾝｼﾞｬﾝ行えば良いの
だろうとは思うのですが･･･。

ｵﾌｾｯﾄ平面をﾘﾈｰﾑ2

こちらの続きです
ｵﾌｾｯﾄ平面をﾘﾈｰﾑ - C#ATIA

imihitoさんから指摘された部分を修正し、座標系平面からの
ｵﾌｾｯﾄ平面も対応させました。

'vba Part_OffsetPleneRename_ver0.0.2  using-'KCL0.0.12'  by Kantoku
Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument,ProductDocument") Then Exit Sub
    
    Dim Msg As String
    Msg = "ｵﾌｾｯﾄ平面を選択して下さい : ESCｷｰ 終了"
    Dim Pln As Plane
    Dim NewName As String
    Do
        Set Pln = KCL.SelectItem(Msg, "Plane")
        If Pln Is Nothing Then Exit Do
        
        'ｵﾌｾｯﾄ平面以外を除去
        If Not (TypeOf Pln Is HybridShapePlaneOffset) Then
            MsgBox "指定面はｵﾌｾｯﾄ平面ではありません"
            GoTo Continue
        End If
        
        '参照毎にﾘﾈｰﾑ名取得
        If InStr(Pln.Plane.DisplayName, "RSur:") > 0 Then
            '座標系の可能性
            NewName = GetAxisPlaneName(Pln)
            If Len(NewName) < 1 Then
                MsgBox "参照面が平面ではありません"
                GoTo Continue
            End If
        Else
            '純粋な平面
            NewName = GetPlaneName(Pln.Plane)
        End If
        
        'ﾘﾈｰﾑ
        With Pln
            .Name = NewName & _
                    Num2Str(.Offset.Value * .Orientation)
        End With
Continue:
    Loop
End Sub

'参照元座標系時の新たな平面名取得
Private Function GetAxisPlaneName(ByVal Pln As Plane) As String
    GetAxisPlaneName = vbNullString
    
    Dim info As Variant
    info = GetBrepInfo(Pln.Plane.DisplayName)
    
    Dim pt As Part
    Set pt = KCL.GetParent_Of_T(Pln, "Part")
    
    Dim inter As String
    Dim ax As AxisSystem
    Dim hit As AxisSystem: Set hit = Nothing
    
    For Each ax In pt.AxisSystems
        inter = KCL.GetInternalName(ax)
        If inter = info(0) Then
            Set hit = ax
            Exit For
        End If
    Next
    If hit Is Nothing Then Exit Function
    
    Dim direction As String
    Select Case info(1)
        Case 1 'XY平面
            direction = "Z"
        Case 2 'YZ平面
            direction = "X"
        Case 3 'ZX平面
            direction = "Y"
        Case Else
            '多分無いはず。止まったら連絡下さい
            Stop
    End Select
    GetAxisPlaneName = hit.Name & "_" & direction & "="
End Function

'BrapNameから参照情報取得
Private Function GetBrepInfo(ByVal BrepName As String) As Variant
    Dim tmp As Variant
    tmp = Split(BrepName, "RSur:(Face:(Brp:(")
    tmp = Split(tmp(1), ")")
    GetBrepInfo = Split(tmp(0), ";")
End Function

'数値を+-付きの文字にする
Private Function Num2Str(ByVal Num As Double) As String
    Num2Str = IIf(Num > 0, "+", "") & CStr(Num)
End Function
 
'新たな平面名取得
Private Function GetPlaneName(ByVal RefPlnName As Reference) As String
    Select Case RefPlnName.DisplayName
        Case "xy plane", "XY平面"
            GetPlaneName = "Z="
        Case "yz plane", "YZ平面"
            GetPlaneName = "X="
        Case "zx plane", "ZX平面"
            GetPlaneName = "Y="
        Case Else
            GetPlaneName = RefPlnName.DisplayName
    End Select
End Function

座標系平面からのｵﾌｾｯﾄ平面の場合、参照元がBrepNameなReferenceと
なってしまいわかり難いのですが、こちらの経験から
参照元のInternalNameが記載されているのは、何となく感じています。
座標系からXY,YZ,ZXの各平面のﾘﾌｧﾚﾝｽを取得2(InternalName) - C#ATIA

それをGetBrepInfo関数で行っているのですが･･･。
文字列操作が結構苦手なんです。Midで何文字目とか、+1したりとか。
いつも間違えちゃうので、大体Splitさせちゃいます。
他の方は間違えませんかね？

ｵﾌｾｯﾄ平面をﾘﾈｰﾑ

ｵﾌｾｯﾄ平面をそれなりの名前に変更するマクロです。
元々持っていたマクロなのですが、あまり使っていませんでした。
最近使ったのでｺｰﾄﾞを綺麗に直しました。

"それなりの名前に"　なのですが、サンプルとしてはこんな感じです。

平面1（黄色）-XY平面からｵﾌｾｯﾄ
平面2（ｵﾚﾝｼﾞ）-平面1からｵﾌｾｯﾄ
平面3（青）-座標系ZX平面からｵﾌｾｯﾄ
平面4（ｵﾚﾝｼﾞ）-平面3からｵﾌｾｯﾄ
の状態です。

マクロを実行し平面をクリックすると、こんな感じになります。

平面1は、XY平面からｵﾌｾｯﾄの為、Z=+20に
平面2は、平面1からｵﾌｾｯﾄの為、"Z=+20" +20 と言う意味合いで
平面3は、座標系ZX平面からｵﾌｾｯﾄの為、ﾘﾈｰﾑしない
平面4は、平面3からｵﾌｾｯﾄの為、”平面3” +20 と言う意味合いで
とリネームします。あくまで参照元が平面の場合のみなんです。
ｵﾌｾｯﾄ平面を座標系派の方、ごめんなさい。　結構難しいんです。

'vba Part_OffsetPleneRename_ver0.0.1  using-'KCL0.0.12'  by Kantoku
Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument,ProductDocument") Then Exit Sub
    
    Dim Msg As String
    Msg = "ｵﾌｾｯﾄ平面を選択して下さい : ESCｷｰ 終了"
    Dim pln As Plane
    
    Do
        Set pln = KCL.SelectItem(Msg, "Plane")
        If pln Is Nothing Then Exit Do
        
        'ｵﾌｾｯﾄ平面以外を除去
        If Not IsPlaneOffset(pln) Then
            MsgBox "指定面はｵﾌｾｯﾄ平面ではありません"
            GoTo Continue
        End If
        
        '参照が平面ｵﾌﾞｼﾞｪｸﾄ以外を除去
        If InStr(pln.Plane.DisplayName, "RSur:") > 0 Then
            MsgBox "参照面が平面ではありません"
            GoTo Continue
        End If
        
        'ﾘﾈｰﾑ
        With pln
            .Name = GetPlaneName(.Plane) & _
                    Num2Str(.Offset.Value * .Orientation)
        End With
Continue:
    Loop
End Sub

'ｵﾌｾｯﾄ平面?
Private Function IsPlaneOffset(ByVal pln As Plane) As Boolean
    Dim tmp As HybridShapePlaneOffset
    On Error Resume Next
        Set tmp = pln
        If Err.Number <> 0 Then
            IsPlaneOffset = False
        Else
            IsPlaneOffset = True
        End If
    On Error GoTo 0
End Function

'数値を+-付きの文字にする
Private Function Num2Str(ByVal num As Double) As String
    Num2Str = IIf(num > 0, "+", "") & CStr(num)
End Function
 
'新たな平面名取得
Private Function GetPlaneName(ByVal RefPlnName As Reference) As String
    Select Case RefPlnName.DisplayName
        Case "xy plane", "XY平面"
            GetPlaneName = "Z="
        Case "yz plane", "YZ平面"
            GetPlaneName = "X="
        Case "zx plane", "ZX平面"
            GetPlaneName = "Y="
        Case Else
            GetPlaneName = RefPlnName.DisplayName
    End Select
End Function

注記内の指定文字を削除する

こちらのｺﾒﾝﾄで、CATIAの質問を頂きました。
CAD Exchanger Cloud - C#ATIA

久々に挑戦しました。

'VBA
'3D注記の指定文字を削除する  by Kantoku

Option Explicit

Sub CATMain()
    Dim keys As Variant '削除対象文字
    keys = Array(".", "_")
    
    '*************
    Dim Doc As PartDocument
    Set Doc = CATIA.ActiveDocument
    
    Dim Pt As Part
    Set Pt = Doc.Part

    Dim msg As String
    
    Dim keysmsg As String 'ﾒｯｾｰｼﾞ用
    keysmsg = "[" & Join(keys, " , ") & "]"
    
    Dim AnnoLst As Collection 'keysを含んだ注記
    Set AnnoLst = GetHasKeysAnnotationLst(Pt.AnnotationSets, keys)
    If AnnoLst.Count < 1 Then
        msg = keysmsg & vbNewLine & "を含んだ [注記] が見つかりませんでした。"
        MsgBox msg
        Exit Sub
    End If
    
    msg = GetAnnotationNames(AnnoLst)
    msg = "以下の[注記]は" & keysmsg & "を含んでいます。" & vbCrLf & _
        msg & vbCrLf & "指定文字を削除しますか?"
    If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
    Call ReplaceAnnotationText(AnnoLst, keys)
    
    MsgBox "Done"
End Sub

'指定文字の削除
Private Sub ReplaceAnnotationText( _
    ByVal AnnoLst As Collection, _
    ByVal keys As Variant)
    
    Dim reg As Object
    Set reg = GetReg(keys)
    
    Dim anno As Annotation
    Dim match As Object
    
    For Each anno In AnnoLst
        Set match = reg.Execute(anno.Text.Text)
        anno.Text.Text = reg.Replace(anno.Text.Text, "")
    Next
End Sub

'ﾒｯｾｰｼﾞ用名前取得
Private Function GetAnnotationNames( _
    ByVal lst As Collection) As String
    
    GetAnnotationNames = vbNullString
    
    Dim ary() As String
    ReDim ary(lst.Count - 1)
    Dim i As Long
    
    For i = 1 To lst.Count
        ary(i - 1) = lst(i).Name
    Next
    GetAnnotationNames = Join(ary, vbCrLf)
End Function

'指定したKeyを持つ注記の取得
Private Function GetHasKeysAnnotationLst( _
    ByVal annoSets As AnnotationSets, _
    ByVal keys As Variant) As Collection
    
    Dim reg As Object
    Set reg = GetReg(keys)
    
    Dim lst As Collection
    Set lst = New Collection
    Dim i As Long, j As Long
    Dim annos As Annotations
    Dim anno As Annotation
    Dim match As Object
    
    For i = 1 To annoSets.Count
        Set annos = annoSets.Item(i).Annotations
        For j = 1 To annos.Count
            Set anno = annos.Item(j)
            
            If Not anno.Type = "FTA_Text" Then GoTo continue
            
            Set match = reg.Execute(anno.Text.Text)
            
            If match.Count < 1 Then GoTo continue
            
            lst.Add anno
continue:
        Next
    Next
    Set GetHasKeysAnnotationLst = lst
End Function

'正規表現
Private Function GetReg(ByVal keys As Variant) As Object

    Dim reg As Object
    Set reg = CreateObject("VBScript.RegExp")
    
    With reg
        .Pattern = "[" & Join(keys) & "]"
        .IgnoreCase = False
        .Global = True
    End With
    Set GetReg = reg
End Function

最初のkeys配列に削除したい文字(文字列じゃないです)を指定して下さい。
上記ｻﾝﾌﾟﾙでは

こんな状態が

この様になります。

ｸﾘｯｸした点の座標値を外部ﾌｧｲﾙにｴｸｽﾎﾟｰﾄ

こちらでｺﾒﾝﾄを頂いたので、ﾘﾊﾋﾞﾘがてら作ってみました。
Excelﾌｫｰﾑﾎﾞﾀﾝからﾏｸﾛの起動 (未確認) - C#ATIA

'vba sample_ExpPointPos_ver0.0.1 by Kantoku
'選択した点の座標値をﾌｧｲﾙにｴｸｽﾎﾟｰﾄ
Option Explicit

'*** ｴｸｽﾎﾟｰﾄするﾌｫｰﾏｯﾄを設定して下さい ***
'txt - ｽﾍﾟｰｽ区切り
'csv - ｶﾝﾏ区切り
'xls - Excelに直接（要Excel起動）
Const ExpType = "csv"
'*********

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'ﾄﾞｷｭﾒﾝﾄ
    Dim Doc As PartDocument
    Set Doc = CATIA.ActiveDocument
    
    'ﾄﾞｷｭﾒﾝﾄﾊﾟｽ
    Dim DocPath As Variant
    DocPath = GetDocDir(Doc)
    
    'excelのみ
    If ExpType = "xls" Then
        Dim Xlapp As Object
        Set Xlapp = GetExcel()
    End If
    
    '点選択
    Dim Filter As Variant
    Filter = Array("Point")
    
    Dim Msg As String
    Msg = "点/頂点を選択してください : [Esc]=ｷｬﾝｾﾙ"
    
    Dim Data As Collection '取得データ格納用
    Set Data = GetPointInfo(Msg, Filter)
    
    If Data.Count < 1 Then End 'ﾃﾞｰﾀ無し
    
    'ｴｸｽﾎﾟｰﾄ
    DocPath(1) = DocPath(1) & "_SelPoint"
    Dim ExpPath As String
    Select Case ExpType
        Case "txt"
            ExpPath = ExpTxt(DocPath, Data, " ", "txt")
        Case "csv"
            ExpPath = ExpTxt(DocPath, Data, ",", "csv")
        Case "xls"
            ExpPath = ExpXls(DocPath, Data, Xlapp)
    End Select
    
    Msg = ExpPath & vbNewLine & _
          CStr(Data.Count) & "個分の座標値をｴｸｽﾎﾟｰﾄしました"
    MsgBox Msg
End Sub

'ｴｸｽﾎﾟｰﾄ - excel
Private Function ExpXls(ByVal Path As Variant, ByVal Data As Collection, _
                        ByVal Xlapp As Object) As String
    Dim Wb As Object 'WookBook
    Set Wb = Xlapp.Workbooks.Add
    
    Dim Ws As Object 'WorkSheet
    Set Ws = Wb.ActiveSheet
    
    Dim I As Long, J As Long
    For I = 1 To Data.Count
        For J = 1 To 4
            Ws.Cells(I, J).value = Data(I).Item(J)
        Next
    Next
    
    Path(2) = "xls"
    Dim ExpPath As String
    ExpPath = GetNewName(JoinPathName(Path))
    Call Wb.SaveAs(ExpPath)
    ExpXls = ExpPath
End Function

'Excel取得
Private Function GetExcel() As Object
    Dim Xlapp As Object 'As Excel.Application
    On Error Resume Next
        Set Xlapp = VBA.GetObject(, "Excel.Application")
    On Error GoTo 0
    If IsNothing(Xlapp) Then
        MsgBox "Excelを起動してから再度実行してください"
        End
    End If
    Set GetExcel = Xlapp
End Function

'ｴｸｽﾎﾟｰﾄ - txt,csv
Private Function ExpTxt(ByVal Path As Variant, ByVal Data As Collection, _
                        ByVal Delim As String, ByVal Ext As String) As String
    Dim Tmp As Collection: Set Tmp = New Collection
    Dim Info As Collection
    For Each Info In Data
        Call Tmp.Add(JoinLst(Info, Delim))
    Next
    
    Path(2) = Ext
    Dim ExpPath As String
    ExpPath = GetNewName(JoinPathName(Path))
    Call WriteFile(ExpPath, JoinLst(Tmp, vbNewLine))
    
    ExpTxt = ExpPath
End Function

'ﾘｽﾄ展開
Private Function JoinLst(ByVal Lst As Collection, ByVal Delim As String)
    Dim t As Variant
    Dim res As String
    For Each t In Lst
        res = res & t & Delim
    Next
    JoinLst = Left(res, Len(res) - Len(Delim))
End Function

'座標値取得
Private Function GetPointInfo(ByVal Msg As String, _
                              ByVal Filter As Variant) As Collection
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Dim Data As Collection: Set Data = New Collection
    Dim Info As Collection
    Dim Pnt As Variant 'As Point
    Dim Pos(2) As Variant 'As Double
    
    Do
        Sel.Clear
        Select Case Sel.SelectElement2(Filter, Msg, False)
            Case "Cancel", "Undo", "Redo"
                Exit Do
        End Select
        Set Pnt = Sel.Item(1).value
        Call Pnt.GetCoordinates(Pos)

        Set Info = New Collection
        With Info
            Call .Add(Pnt.Name)
            Call .Add(CStr(Pos(0)))
            Call .Add(CStr(Pos(1)))
            Call .Add(CStr(Pos(2)))
        End With
        Call Data.Add(Info)
    Loop
    Set GetPointInfo = Data
End Function

'ﾄﾞｷｭﾒﾝﾄのﾊﾟｽ取得
Private Function GetDocDir(ByVal Doc As PartDocument) As Variant
    Dim Path As Variant
    Path = SplitPathName(Doc.FullName)
    If Len(Path(0)) < 1 Then
        MsgBox "CATPartﾌｧｲﾙを一度保存してください!!)"
        End
    End If
    GetDocDir = Path
End Function

'*** kclより流用 ***
'こちらを同じﾌﾟﾛｼﾞｪｸﾄ内にKCL.bas(標準ﾓｼﾞｭｰﾙ)として入れてある場合は
'以下のｺｰﾄﾞは不要です。
'http://kantoku.hatenablog.com/entry/2016/06/21/111410
'http://kantoku.hatenablog.com/entry/2016/12/27/194117


'ﾏｸﾛｽﾀｰﾄﾁｪｯｸ
''' @param:DocTypes-array(string),string ﾏｸﾛ実行を許可するﾄﾞｷｭﾒﾝﾄのﾀｲﾌﾟ
''' @return:Boolean
Private Function CanExecute(ByVal DocTypes As Variant) As Boolean
    CanExecute = False
    
    If CATIA.Windows.Count < 1 Then
        MsgBox "ﾌｧｲﾙが開かれていません"
        Exit Function
    End If
    
    If VarType(DocTypes) = vbString Then DocTypes = Split(DocTypes, ",")
    If Not IsFilterType(DocTypes) Then Exit Function
    
    Dim ErrMsg As String
    ErrMsg = "ﾌｧｲﾙのﾀｲﾌﾟが異なります。" + vbNewLine + "(" + Join(DocTypes, ",") + " のみです)"
    
    Dim ActDoc As Document
    On Error Resume Next
        Set ActDoc = CATIA.ActiveDocument
    On Error GoTo 0
    If ActDoc Is Nothing Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    If UBound(Filter(DocTypes, TypeName(ActDoc))) < 0 Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    CanExecute = True
End Function

'ﾌｨﾙﾀｰﾀｲﾌﾟとしてOK?
Private Function IsFilterType(ByVal Ary As Variant) As Boolean
    IsFilterType = False
    Dim ErrMsg$: ErrMsg = "ﾌｨﾙﾀｰ又はﾄﾞｷｭﾒﾝﾄﾀｲﾌﾟの指定は" + vbNewLine + _
                          "Variant(String)型配列で行ってください" + vbNewLine + _
                          "(ﾏｸﾛｺｰﾄﾞのｴﾗｰです)"
    
    If Not IsStringAry(Ary) Then
        MsgBox ErrMsg
        Exit Function
    End If
    
    IsFilterType = True
End Function

'文字型配列?
Private Function IsStringAry(ByVal Ary As Variant) As Boolean
    IsStringAry = False
    
    If Not IsArray(Ary) Then Exit Function
    Dim I&
    For I = 0 To UBound(Ary)
        If Not VarType(Ary(I)) = vbString Then Exit Function
    Next
    
    IsStringAry = True
End Function

'FileSystemObject
''' @return:Object(Of FileSystemObject)
Private Function GetFSO() As Object
    Set GetFSO = CreateObject("Scripting.FileSystemObject")
End Function

'ﾊﾟｽ/ﾌｧｲﾙ名/拡張子 分割
''' @param:FullPath-ﾌｧｲﾙﾊﾟｽ
''' @return:Variant(Of Array(Of String)) (0-Path 1-BaseName 2-Extension)
Private Function SplitPathName(ByVal FullPath$) As Variant
    Dim Path(2) As String
    With GetFSO
        Path(0) = .getParentFolderName(FullPath)
        Path(1) = .GetBaseName(FullPath)
        Path(2) = .GetExtensionName(FullPath)
    End With
    SplitPathName = Path
End Function

'ﾊﾟｽ/ﾌｧｲﾙ名/拡張子 連結
''' @param:Path-Variant(Of Array(Of String)) (0-Path 1-BaseName 2-Extension)
''' @return:ﾌｧｲﾙﾊﾟｽ
Private Function JoinPathName$(ByVal Path As Variant)
    If Not IsArray(Path) Then Stop '未対応
    If Not UBound(Path) = 2 Then Stop '未対応
    JoinPathName = Path(0) + "\" + Path(1) + "." + Path(2)
End Function

'ﾌｧｲﾙ,ﾌｫﾙﾀﾞの有無
''' @param:Path-ﾊﾟｽ
''' @return:Boolean
Private Function IsExists(ByVal Path$) As Boolean
    IsExists = False
    Dim FSO As Object: Set FSO = GetFSO
    If FSO.FileExists(Path) Then
        IsExists = True: Exit Function 'ﾌｧｲﾙ
    ElseIf FSO.FolderExists(Path) Then
        IsExists = True: Exit Function 'ﾌｫﾙﾀﾞ
    End If
    Set FSO = Nothing
End Function

'重複しない名前取得
''' @param:Path-ﾌｧｲﾙﾊﾟｽ
''' @return:新たなﾌｧｲﾙﾊﾟｽ
Private Function GetNewName$(ByVal OldPath$)
    Dim Path As Variant
    Path = SplitPathName(OldPath)
    Path(2) = "." & Path(2)
    Dim NewPath$: NewPath = Path(0) + "\" + Path(1)
    If Not IsExists(NewPath + Path(2)) Then
        GetNewName = NewPath + Path(2)
        Exit Function
    End If
    Dim TempName$, I&: I = 0
    Do
        I = I + 1
        TempName = NewPath + "_" + CStr(I) + Path(2)
        If Not IsExists(TempName) Then
            GetNewName = TempName
            Exit Function
        End If
    Loop
End Function

'ﾌｧｲﾙの書き込み
''' @param:Path-ﾌｧｲﾙﾊﾟｽ
''' @param:Txt-String
Private Sub WriteFile(ByVal Path$, ByVal txt) '$)
    Call GetFSO.OpenTextFile(Path, 2, True).Write(txt)
End Sub

ﾏｸﾛ起動後、大したﾒｯｾｰｼﾞもありませんが点を次々とｸﾘｯｸして頂き
ESCｷｰを押す事でCATPartﾌｧｲﾙと同じﾌｫﾙﾀﾞ内に
"[CATPartﾌｧｲﾙ名]_SelPoint.xxx "
と言う名称のﾌｧｲﾙが出来上がります。
（上書き保存を避けるため、同一名のファイルがある場合 "_[数字]"が追加されます）

・CATPartﾌｧｲﾙがｱｸﾃｨﾌﾞになっている必要が有り、一度保存しておく必要が有ります。
　（保存先ﾊﾟｽを取得する為）
・事前にｺｰﾄﾞを設定する必要がありますが(最初の方の部分です)、対応ﾌｫｰﾏｯﾄは
　txt,csv,xlsです。
・xlsの場合、事前にExcelを起動しておく必要が有ります。
・ｴｸｽﾎﾟｰﾄされたﾌｧｲﾙは以下の状態です。
　[名称 , X値 , Y値 , Z値]
・Excel操作部分のｺｰﾄﾞは、世間の皆様の方がきっと素晴らしいと思います。
・ｺｰﾄﾞ内にも記載しましたが、KCLを利用する場合は後半のｺｰﾄﾞは不要です。
非常に個人的なCATVBA用ﾗｲﾌﾞﾗﾘ - C#ATIA
不覚にも、KCLのご利用をお考えの方へ - C#ATIA