2018-06-29

DrawingTextの中心座標

CATIA_V5 VBA

DrawingTextの中心座標を取得したい　との記載を見て思い付きで書きました。
Size of the textbox on a drawing - DASSAULT: CATIA products - Eng-Tips
最初に、”遅いよ”　って書いたんですけどね。

リトルクトゥルフさんがｱｯｻﾘ答えを書いてくれました。
・・・やっぱりレベルが違いすぎですね。

ｺｰﾄﾞが書かれていなかったので、作ってみたものの
リーダー（引き出し線）の削除でｴﾗｰになっちゃいます。

DrawingText.Leaders.Remove(0)

ん～　ｴﾗｰにはなるものの削除は出来てます。
仕方ないので On Error Resume Next　でｴﾗｰを回避するように
したのは良いのですが、すっきりしない。

探しまくってやっとCOEの記載を発見しました。
COE : Forums : Text box size
どうやっているのかな？　と思い見てみると
やっぱり On Error Resume Next　してます・・・。

僕だけじゃないようなので、すっきり。

2018-06-27

VBA 言語環境による挙動の違い

CATIA_V5 VBA

先日のマクロですが、上手く動かないらしいのです。
draw with a catia all the Dual Geodesic Icosahedra - DASSAULT: CATIA products - Eng-Tips

原因が良くわからないのですが、CATIAのリリース違いが
影響するような程の最新の機能は使っていないはずです。

知識が無い為何とも言えないのですが、残る可能性は
言語の違いかと思っています。
マクロの内容的に、処理を速めるために正規表現を利用しているのですが
この辺がエンコードで上手く機能しないとか、ｴｸｽﾎﾟｰﾄしたVBAﾌｧｲﾙ
（~.bas,~cls）が、他の言語だと文字化けし機能しないとか･･･。

何か情報をお持ちの方、教えて頂けると助かります。

2018-06-26

Dual Geodesic Icosahedra3

CATIA_V5 VBA

こちらの続きです。
Dual Geodesic Icosahedra2 - C#ATIA

完成したので、テストデータと共にGrabCADにUpしました。
恐らく誰にも役には立たないでしょう。
3D CAD Model Collection | GrabCAD Community Library
結局一番苦労したのは、正規表記のﾊﾟﾀｰﾝでした。
未だに宝探しをしている気分です。

面の作成に失敗していた理由がわかりました。
Visual PolyhedraのサイトにUpされている座標ﾃﾞｰﾀの中に
こんな感じの☆型の面を、5個の頂点だけで表現している
データがあります。
f:id:kandennti:20180626165307p:plain
ﾌｨﾙｻｰﾌｪｽを利用して面を作成している為、こんな感じの自己交差
した状態ではｴﾗｰになる為、面が抜けてしまったようです。
対応策を考えるのも面倒な為、そのままにしました。

実は、こんなｽｹｯﾁでもFusion360は面が作れるんですよね。
こちらでそれを利用したものを作りました。
Solved: How to remove inner sketch lines from an intersection sketch? - Autodesk Community
ｽｹｯﾁの考え方の違いを利用しています。

Upしたﾏｸﾛﾌｧｲﾙの "SurfaceFactory.cls" ですが(生意気なﾈｰﾐﾝｸﾞで申し訳ないのです)
このﾏｸﾛだけではなく、他にも利用できるように考えて作っています。
英語じゃ書けそうになかったので、こちらで説明を。

3D点：array(double,double,double) でXYZの順です。都合上ArrayVariantです。
一枚の面：array(3D点,3D点,3D点…）です。各頂点を表す為、当然3点以上が必要です。
複数の面:array(一枚の面,一枚の面,一枚の面･･･）です。

一枚だけ面を作成したい場合は、ary(ary,･･･)　な感じです。

Sub Example_Single()
    'ﾊﾟｰﾄﾄﾞｷｭﾒﾝﾄ
    Dim doc As PartDocument: Set doc = CATIA.Documents.Add("Part")
    
    '座標値
    Dim pos As Variant
    pos = Array(Array(0, 0, 0), Array(1, 0, 0), Array(0, 1, 0))
    
    'SurfaceFactoryｲﾝｽﾀﾝｽ
    Dim surfFact As SurfaceFactory: Set surfFact = New SurfaceFactory
    
    '面を作成するﾊﾟｰﾄﾄﾞｷｭﾒﾝﾄをｾｯﾄ
    Call surfFact.SetPartDoc(doc)
    
    '座標値から面を作成 - 形状ｾｯﾄには入りません!
    '戻りは HybridShapeSurfaceExplicit
    Dim surf As HybridShapeSurfaceExplicit
    Set surf = surfFact.CreateSurf(pos)
    
    '形状ｾｯﾄに挿入
    Dim hBody As HybridBody: Set hBody = doc.Part.hybridBodies.Add()
    Call hBody.AppendHybridShape(surf)
    
    'ｲﾝｽﾀﾝｽ破棄 - 破棄することで内部の一時的なものを削除します。
    Set surfFact = Nothing
End Sub

複数面であれば、ary(ary(ary,･･･),･･･)　な感じです。

Sub Example_Multi()
    'ﾊﾟｰﾄﾄﾞｷｭﾒﾝﾄ
    Dim doc As PartDocument: Set doc = CATIA.Documents.Add("Part")
    
    '座標値郡
    Dim posary As Variant
    posary = Array( _
                Array(Array(0, 0, 0), Array(1, 0, 0), Array(0, 1, 0)), _
                Array(Array(0, 0, 0), Array(0, 1, 0), Array(-1, 1, 0)), _
                Array(Array(0, 0, 0), Array(-1, 0, 0), Array(0, -1, 0)), _
                Array(Array(0, 0, 0), Array(0, -1, 0), Array(1, -1, 0)))
    
    'SurfaceFactoryｲﾝｽﾀﾝｽ
    Dim surfFact As SurfaceFactory: Set surfFact = New SurfaceFactory
    
    '面を作成するﾊﾟｰﾄﾄﾞｷｭﾒﾝﾄをｾｯﾄ
    Call surfFact.SetPartDoc(doc)
    
    '座標値郡から面郡を作成 - 形状ｾｯﾄには入りません!
    '戻りは Collectiont
    Dim surfs As Collection
    Set surfs = surfFact.CreateSurfs(posary)
    
    '形状ｾｯﾄに挿入
    Dim hBody As HybridBody: Set hBody = doc.Part.hybridBodies.Add()
    Dim surf As HybridShapeSurfaceExplicit
    For Each surf In surfs
        Call hBody.AppendHybridShape(surf)
    Next
    
    'ｲﾝｽﾀﾝｽ破棄 - 破棄することで内部の一時的なものを削除します。
    Set surfFact = Nothing
    
End Sub

で、折れ線とフィルで作成可能な面が作れます。
その為、STLや3DDXF等のポリゴンっぽいものも、座標値配列にさえすれば
流用可能です。　恐らく使わないですが。

2018-06-05

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

2018-05-29

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

CATIA_V5 VBA KCL

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

2018-05-16

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

CATIA_V5 VBA

「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部分に
ｾｸｼｮﾝが残ります。（使い道は無いのですが）
f:id:kandennti:20180516161755p:plain

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

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

2018-04-27

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

CATIA_V5 VBA KCL

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

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

f:id:kandennti:20180427095941p:plain

'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させちゃいます。
他の方は間違えませんかね？