こちらの続き？ です。
ThickOnTheFly1 - C#ATIA
こちら作りかけて止めました。続けてもいないのですがｺｰﾄﾞを
記載していなかったので････。
正直な所、変数・関数名等が酷いのですが、直す気力がありません。
Private Const MaxLng = 2000000#
Private Const MinLng = 0.002
Sub CATMain()
Dim Sel
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
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
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
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)
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)
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
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
Private Sub UpdateScene(ByVal Scene As Variant)
Dim Viewer As Viewer3D: Set Viewer = CATIA.ActiveWindow.activeviewer
Dim VPnt3D As Variant
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
確か、一度XY平面を通過する位置にマウスを移動しないと、厚みが表示されなかった
記憶です。（奥行きの値を取得する為です）
最初に必要となるGSDの要素をHybridShapeFactoryで作り出し、
マウスを動かす度にUpdateしまくり、厚みを表示させています。
そのため、ﾁﾗﾂｷ感が酷いです。
「厚みを表示」と書いておりますが、算出方法が（少なくとも）2種類あり
こちらのサイトの "RAY法" になるのだと思います。
GeomCaliper | ジオムキャリパー | CATIA V5モデルの肉厚の測定と表示 | アイコクアルファ株式会社
本当は "Sphere法" を行いたいのですが、ｱﾙｺﾞﾘｽﾞﾑが良くわからないんです。
（測定対象となる相手の面さえ見つければ良いのですが、効率良く見つけ出す方法が
わかりません）
・・・先日知ったのですが、海外の方もここを見て頂いているようでして、
3年ぐらい続けるとそんな事もあるんですね。
