C#ATIA

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

ThickOnTheFly2

CATIA_V5 VBA KCL

こちらの続き？　です。
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年ぐらい続けるとそんな事もあるんですね。