↑タイトル詐欺 主にCATIA V5 の VBA(最近はPMillマクロとFusion360APIが多い)


こちらの続き? です。
ThickOnTheFly1 - C#ATIA

'vba using-'KCL0.0.12'

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)
    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)
    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"
        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
                        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
End Sub

Private Sub SetColor(ByVal Shp As AnyObject)
    With CATIA.ActiveDocument.Selection
        .Add Shp
        .VisProperties.SetRealColor 0, 255, 0, 1
        .VisProperties.SetSymbolType 4
    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
    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) _
    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

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

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



こちらのサイトの "RAY法" になるのだと思います。
GeomCaliper | ジオムキャリパー | CATIA V5モデルの肉厚の測定と表示 | アイコクアルファ株式会社
本当は "Sphere法" を行いたいのですが、アルゴリズムが良くわからないんです。