こちらの続きです。
3Dな注記の位置を制御出来ているっぽい(条件付き) - C#ATIA
やっと完成しました。
注記位置については前回通り、条件付となりますが結構満足してます。
Option Explicit
Private Const ArwBodyLeng = 20#
Private Const ArwLeng = 5#
Private Const ArwAng = 30#
Private Const TxtHeader = "t="
Sub CATMain()
If Not CanExecute(Array("PartDocument", "ProductDocument")) Then Exit Sub
Dim Elm As Variant
Set Elm = KCL.SelectElement("面を選択", "Face")
If KCL.IsNothing(Elm) Then Exit Sub
Dim Pos(2) As Variant
Call Elm.GetCoordinates(Pos)
Dim Pt As Part
Set Pt = Elm.Document.Part
Dim Fact As HybridShapeFactory
Set Fact = Pt.HybridShapeFactory
Dim DelList As Collection
Set DelList = New Collection
Dim SurfRef As Reference
Set SurfRef = Elm.Reference
Dim PntRef As Reference
Set PntRef = CreatePntRef(Pt, Fact, Pos)
Call DelList.Add(PntRef)
Dim Rev As Boolean: Rev = True
Dim Msg As String: Msg = "向きを逆転しますか?"
Dim HBdy As HybridBody
Do
Dim LinRef As Reference
Set LinRef = CreateNormalRef(Pt, Fact, SurfRef, PntRef, 0#, ArwBodyLeng, Rev)
Call DelList.Add(LinRef)
Dim PntOnRef As Reference
Set PntOnRef = CreatePntOnCrvRef(Pt, Fact, LinRef, ArwLeng, Rev)
Call DelList.Add(PntOnRef)
Dim PlnRef As Reference
Set PlnRef = CreatePlnRef(Pt, Fact, LinRef, PntRef)
Call DelList.Add(PlnRef)
Dim Crl As HybridShapeCircleCtrRad
Set Crl = CreateCrl(Pt, Fact, PntOnRef, PlnRef, ArwAng, ArwLeng)
Call DelList.Add(Crl)
Dim SrtRef As Reference
Set SrtRef = CreateEndPntRef(Pt, Fact, Crl, True)
Call DelList.Add(SrtRef)
Dim EndRef As Reference
Set EndRef = CreateEndPntRef(Pt, Fact, Crl, False)
Call DelList.Add(EndRef)
Dim PlyRef As Reference
Set PlyRef = CreatePlyRef(Pt, Fact, SrtRef, PntRef, EndRef)
Call DelList.Add(PlyRef)
Dim JoinRef As Reference
Set JoinRef = CreateJoinRef(Pt, Fact, LinRef, PlyRef)
Call DelList.Add(JoinRef)
Dim Dtm As HybridShape
Set Dtm = ToDatum(Pt, Fact, JoinRef)
If KCL.IsNothing(HBdy) Then
Set HBdy = Pt.HybridBodies.Add()
End If
Call HBdy.AppendHybridShape(Dtm)
If MsgBox(Msg, vbYesNo) = vbYes Then
Call Fact.DeleteObjectForDatum(Dtm)
Rev = IIf(Rev, False, True)
Else
Exit Do
End If
Loop
Dim Thick As Double
Thick = TryGetThickness(Pt, Fact, SurfRef, PntRef, Rev)
Msg = "厚みを入力してください" & vbNewLine & _
"※注記には [ " & TxtHeader & _
" ] が、追記されます" & vbNewLine & _
"(空欄 又は Cancel で 中止)"
Dim AnnoTxt As String: AnnoTxt = InputTxt(Msg, Thick)
If Not AnnoTxt = vbNullString Then
Call CreateAnnotation(Pt, Fact, Dtm, Rev, TxtHeader & AnnoTxt)
Call HideTPSView
Else
Call RemoveItem(HBdy)
End If
Dim Ref As Reference
For Each Ref In DelList
Call Fact.DeleteObjectForDatum(Ref)
Next
MsgBox "Done"
End Sub
Private Sub RemoveItem(ByVal Itm As AnyObject)
With CATIA.ActiveDocument.Selection
.Clear
.Add Itm
.Delete
End With
End Sub
Private Function InputTxt( _
ByVal Msg As String, _
ByVal Thick As Double) As String
Dim DefTxt As String
DefTxt = IIf(Thick <= 0, vbNullString, CStr(Round(Thick, 3)))
Dim Txt As String
Do
Txt = InputBox(Msg, , DefTxt)
If Txt = vbNullString Then Exit Do
If IsNumeric(Txt) Then Exit Do
MsgBox "数字を入力して下さい!", vbOKOnly + vbExclamation
Loop
InputTxt = Txt
End Function
Private Sub HideTPSView()
With CATIA.ActiveDocument.Selection
.Clear
.Search "CATTPSSearch.CATTPSView,all"
.VisProperties.SetShow catVisPropertyNoShowAttr
End With
End Sub
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
Private Sub CreateAnnotation( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal Arw As HybridShape, _
ByVal Rev As Boolean, _
ByVal Txt As String)
Dim Idx As Long: Idx = IIf(Rev, 4, 3)
Dim sel As Selection: Set sel = Pt.Parent.Selection
Dim SelName As String
With sel
.Clear
.Add Arw
.Search "Topology.CGMVertex,sel"
SelName = .Item2(Idx).Reference.Name
.Clear
End With
Dim PntRef As Reference
Set PntRef = Pt.CreateReferenceFromBRepName(KCL.GetBrepName(SelName), Arw)
Dim Pnt As Variant
Set Pnt = Fact.AddNewPointDatum(PntRef)
Dim Pos(2) As Variant
Call Pnt.GetCoordinates(Pos)
Call Fact.DeleteObjectForDatum(Pnt)
Dim NowVw As Variant
NowVw = GetScene3D(GetViewPnt3D)
Call UpdateScene(Array(0, 0, 0, 0, 0, -1, 0, 1, 0, 0, 0))
Dim USurf As UserSurface
Set USurf = Pt.UserSurfaces.Generate(PntRef)
Dim ATSet As AnnotationSet
Set ATSet = Pt.AnnotationSets.Add("")
Dim Anno As Annotation
Set Anno = ATSet.AnnotationFactory.CreateEvoluateText(USurf, Pos(0), Pos(1), Pos(2), False)
Anno.Text.Text = Txt
Call Pt.UpdateObject(Anno)
Call UpdateScene(NowVw)
End Sub
Private Function TryGetThickness( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal SurfRef As Reference, _
ByVal PntRef As Reference, _
ByVal Rev As Boolean) As Double
TryGetThickness = -1#
Dim PBody As Body: Set PBody = KCL.GetParent_Of_T(SurfRef, "Body")
If KCL.IsNothing(PBody) Then Exit Function
Dim Shps As Shapes: Set Shps = PBody.Shapes
Dim ShpRef As Reference: Set ShpRef = Pt.CreateReferenceFromGeometry(Shps.Item(Shps.Count))
Dim DelList As Collection: Set DelList = New Collection
Rev = IIf(Rev, False, True)
Dim LinRef As Reference
Set LinRef = CreateNormalRef(Pt, Fact, SurfRef, PntRef, 0.002, 20000000#, Rev)
Call DelList.Add(LinRef)
Dim InterRef As Reference
Set InterRef = GetIntersectRef(Pt, Fact, ShpRef, LinRef)
If KCL.IsNothing(InterRef) Then GoTo ExitGetThickness
Call DelList.Add(InterRef)
Dim NearRef As Reference
Set NearRef = GetNearRef(Pt, Fact, InterRef, PntRef)
Call DelList.Add(NearRef)
TryGetThickness = GetMaximumLength(Pt, PntRef, NearRef)
ExitGetThickness:
Dim Ref As Reference
For Each Ref In DelList
Call Fact.DeleteObjectForDatum(Ref)
Next
End Function
Private Function GetMaximumLength(ByVal Pt As Part, _
ByVal Ref1 As Reference, _
ByVal Ref2 As Reference) As Double
GetMaximumLength = Pt.Parent.GetWorkbench("SPAWorkbench") _
.GetMeasurable(Ref1) _
.GetMinimumDistance(Ref2)
End Function
Private Function GetNearRef( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal InterRef As Reference, _
ByVal PntRef As Reference) As Reference
Dim Near As HybridShapeNear
Set Near = Fact.AddNewNear(InterRef, PntRef)
Call Pt.UpdateObject(Near)
Set GetNearRef = Pt.CreateReferenceFromObject(Near)
End Function
Private Function GetIntersectRef( _
ByVal Pt As Part, _
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
On Error Resume Next
Call Pt.UpdateObject(Inter)
If Not Err.Number = 0 Then
Err.Number = 0
Call Fact.DeleteObjectForDatum(Inter)
Exit Function
End If
On Error GoTo 0
Set GetIntersectRef = Pt.CreateReferenceFromObject(Inter)
End Function
Private Function CreateJoinRef( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal LinRef As Reference, _
ByVal PlyRef As Reference) As Reference
Dim Join As HybridShapeAssemble
Set Join = Fact.AddNewJoin(LinRef, PlyRef)
With Join
.SetConnex 1
.SetManifold 0
.SetSimplify 0
.SetSuppressMode 0
.SetDeviation 0.001
.SetAngularToleranceMode 0
.SetAngularTolerance 0.5
.SetFederationPropagation 0
End With
Call Pt.UpdateObject(Join)
Set CreateJoinRef = Pt.CreateReferenceFromObject(Join)
End Function
Private Function CreatePlyRef( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal Ref1 As Reference, _
ByVal Ref2 As Reference, _
ByVal Ref3 As Reference) As Reference
Dim Ply As HybridShapePolyline
Set Ply = Fact.AddNewPolyline()
With Ply
.InsertElement Ref1, 1
.InsertElement Ref2, 2
.InsertElement Ref3, 3
.Closure = False
End With
Call Pt.UpdateObject(Ply)
Set CreatePlyRef = Pt.CreateReferenceFromObject(Ply)
End Function
Private Function CreateEndPntRef( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal Crl As HybridShapeCircleCtrRad, _
ByVal StartEndFg As Boolean) As Reference
Dim Cnt(2) As Variant
Call Fact.GSMGetObjectFromReference(Crl.Center).GetCoordinates(Cnt)
Dim R As Double
R = Crl.Radius.Value
Dim Pos(2) As Variant
Dim Direct As HybridShapeDirection
Set Direct = Crl.FirstDirection
Pos(0) = Direct.GetXVal
Pos(1) = Direct.GetYVal
Pos(2) = Direct.GetZVal
Dim i As Long
For i = 0 To UBound(Pos)
Pos(i) = (Pos(i) * R * IIf(StartEndFg, 1, -1)) + Cnt(i)
Next
Set CreateEndPntRef = CreatePntRef(Pt, Fact, Pos)
End Function
Private Function CreateCrl( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal PntRef As Reference, _
ByVal PlnRef As Reference, _
ByVal Ang As Double, _
ByVal Leng As Double) As HybridShapeCircleCtrRad
Dim PAI As Double: PAI = 4 * Atn(1)
Dim R As Double: R = Tan((Ang * 0.5) * PAI / 180) * Leng
Dim Crl As HybridShapeCircleCtrRad
Set Crl = Fact.AddNewCircleCtrRadWithAngles(PntRef, PlnRef, False, R, 0#, 180#)
Call Pt.UpdateObject(Crl)
Set CreateCrl = Crl
End Function
Private Function CreatePlnRef( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal CrvRef As Reference, _
ByVal PntRef As Reference) As Reference
Dim Pln As HybridShapePlaneNormal
Set Pln = Fact.AddNewPlaneNormal(CrvRef, PntRef)
Call Pt.UpdateObject(Pln)
Set CreatePlnRef = Pt.CreateReferenceFromObject(Pln)
End Function
Private Function CreatePntOnCrvRef( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal CrvRef As Reference, _
ByVal Leng As Double, _
ByVal Rev As Boolean) As Reference
Dim Pnt As HybridShapePointOnCurve
Set Pnt = Fact.AddNewPointOnCurveFromDistance(CrvRef, Leng, Rev)
Pnt.DistanceType = 1
Call Pt.UpdateObject(Pnt)
Set CreatePntOnCrvRef = Pt.CreateReferenceFromObject(Pnt)
End Function
Private Function ToDatum( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal Ref As Reference) As HybridShape
Dim Dtm As HybridShape
Set Dtm = Fact.AddNewCurveDatum(Ref)
Call Pt.UpdateObject(Dtm)
Set ToDatum = Dtm
End Function
Private Function CreatePntRef( _
ByVal Pt As Part, _
ByVal Fact As HybridShapeFactory, _
ByVal ary As Variant) As Reference
Dim Pnt As HybridShapePointCoord
Set Pnt = Fact.AddNewPointCoord(ary(0), ary(1), ary(2))
Call Pt.UpdateObject(Pnt)
Set CreatePntRef = Pt.CreateReferenceFromObject(Pnt)
End Function
Private Function CreateNormalRef( _
ByVal Pt As Part, _
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)
Call Pt.UpdateObject(Lin)
Set CreateNormalRef = Pt.CreateReferenceFromObject(Lin)
End Function
かなり長めのコードになってしまいました。
実は、昨日の時点でほぼ出来上がっていたのですが、少し機能を
追加することにしました。
実行した際は、このような感じになります。
最初の動作はサーフェスをクリックした場合です。
2回目の操作はボディをクリックし、向きが相応しくない場合です。
3回目以降はボディをクリックし、意図した向きに矢印を作成した場合です。
3回目以降は、注記文字を入力する為のダイアログのデフォルトとして
数値が入っています。 これは自動で厚みを測定しています。
但し、条件によっては正しくない値が表示される為、完全ではない事を
考慮しておいてください。
(アホみたいな桁数にならないように、小数点以下3桁にしています)
・・・結構、ツールとして使えるかも。