'vba Class1.cls
Option Explicit

Private WithEvents mBtn As MSForms.CommandButton

Sub InitBtn(ByVal Btn As MSForms.CommandButton)
    Set mBtn = Btn
End Sub

Private Sub mBtn_Click()
    Dim Msg$
    Msg = "オートコンプリートで、" & vbNewLine & _
    "ControlTipText出ませんが" & vbNewLine & _
    "このボタンでは[ " & mBtn.ControlTipText & " ]です"
    MsgBox Msg
End Sub

続いて標準モジュール。　名前は "Module1" です。

'vba Module1.bas
Option Explicit

Sub FormTest()
    Dim CapAry As Variant: CapAry = Split("hoge,piyo,fuga", ",")
    Dim TipAry As Variant: TipAry = Split("foo,bar,baz", ",")
    Dim BtnInfoAry() As Variant: ReDim BtnInfoAry(UBound(CapAry))
    Dim i&
    
    For i = 0 To UBound(CapAry)
        BtnInfoAry(i) = Array(CapAry(i), TipAry(i))
    Next
    
    Call Init_Form(BtnInfoAry)
End Sub
Private Function Init_Form(ByVal InfoAry As Variant) As UserForm1
    Dim BtnCnt&: BtnCnt = UBound(InfoAry)
    Dim Uf As UserForm1: Set Uf = UserForm1
    
    With Uf
        .Width = 70
        .Height = (BtnCnt + 1) * 20 + 30
    End With
    
    Dim i&, Btn As MSForms.CommandButton
    Dim BtnAry() As Class1: ReDim BtnAry(BtnCnt)
    For i = 0 To BtnCnt
        Set Btn = Uf.Controls.Add("Forms.CommandButton.1", i, True)
        With Btn
            .Top = 5 + (i) * 20
            .Left = 5
            .Height = 20
            .Width = 70
            .Caption = InfoAry(i)(0)
            .ControlTipText = InfoAry(i)(1)
        End With
        Set BtnAry(i) = New Class1
        Call BtnAry(i).InitBtn(Btn)
    Next
    UserForm1.Show
End Function

Init_Form関数は戻り値返していないのですが、後のﾃｽﾄの為です。
この関数のキモは、こちら

    Dim Uf As UserForm1: Set Uf = UserForm1

ｲﾝｽﾀﾝｽを生成しているのではなく、最初に作った空っぽのForm自体を
受け取っています。
で、この状態であれば無事動き、イベントも発生します。
f:id:kandennti:20171006002619p:plain
自宅なのでExcelでやってますが、CATIAでも同じでした。

問題はここから。先程の部分をｲﾝｽﾀﾝｽに変更します。

    Dim Uf As UserForm1: Set Uf = New UserForm1

これだと、イベントが発生しません・・・。

又、ｲﾝｽﾀﾝｽではなく最初の状態に戻し、

'vba Module1.bas
Option Explicit

Sub FormTest()
 ・・・
    Dim Uf As UserForm1
    Set Uf = Init_Form(BtnInfoAry)
    Uf.Show 
End Sub

Private Function Init_Form(ByVal InfoAry As Variant) As UserForm1
    Dim BtnCnt&: BtnCnt = UBound(InfoAry)
    Dim Uf As UserForm1: Set Uf = UserForm1

 ・・・
    Next
    'UserForm1.Show
    Set Init_Form = Uf
End Function

FormTest側で戻り値を受け取り、FormTest側でShowさせても
同様にｲﾍﾞﾝﾄが発生しません。
（本当はこうしたかったので、関数名をInit_Formしたのに…）

こんなもんなのでしょうか？

追記です。　教えていただきました。
フォームモジュールは空っぽではなく、この様にしました。

'vba UserForm1.frm
Option Explicit

Private mAry As Variant

Sub SetBtn(ByVal Ary As Variant)
    mAry = Ary
End Sub

標準ﾓｼﾞｭｰﾙはこの様に

'vba Module1.bas
Option Explicit

Sub FormTest()
 ・・・
    Dim Uf As UserForm1
    Set Uf = Init_Form(BtnInfoAry)
    Uf.Show 
End Sub

Private Function Init_Form(ByVal InfoAry As Variant) As UserForm1
    Dim BtnCnt&: BtnCnt = UBound(InfoAry)
    Dim Uf As UserForm1: Uf = New UserForm1

 ・・・
    Next
    'UserForm1.Show
    Call Uf.SetBtn(BtnAry)
    Set Init_Form = Uf
End Function

これで上手く行きました。　ありがとうございます。

2017-10-04

1つのPartからBody毎にしたProductを作り出す2

CATIA_V5 VBA KCL

予め、お伝えしておきます。
KCLを更新しました。
非常に個人的なCATVBA用ﾗｲﾌﾞﾗﾘ - C#ATIA

ﾘﾝｸの画面やｶﾀﾛｸﾞ等を開いた状態でﾏｸﾛを実行すると、
ｴﾗｰで止まってしまうのを防ぎたかったので。

こちらの続きです。
1つのPartからBody毎にしたProductを作り出す - C#ATIA

前回のｺﾒﾝﾄに書いたｿｰｽｺｰﾄﾞは少し参考にさせてもらいました。
あちらのものより処理は速いかな？　とは思います。

'vba sample_Part2Product_ver0.0.2  using-'ver0.0.11'
'PartからProduct化します
'ﾎﾞﾃﾞｨ･形状ｾｯﾄ･時系列形状ｾｯﾄで表示されているもののみ
'(ｽｹｯﾁは対象外)

Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'Part
    Dim BaseDoc As PartDocument: Set BaseDoc = CATIA.ActiveDocument
    
    Dim BasePath As Variant: BasePath = Array(BaseDoc.FullName)
    
    Dim Pt As Part: Set Pt = BaseDoc.Part
    
    Dim LeafItems As Collection: Set LeafItems = Get_LeafItemLst(Pt.Bodies)
    
    Dim Msg As String
    If LeafItems Is Nothing Then
        Msg = "ｺﾋﾟｰ可能な要素がありません!"
        MsgBox Msg, vbOKOnly + vbExclamation
        Exit Sub
    End If
    
    '確認
    Msg = LeafItems.Count & "個のｺﾋﾟｰ可能な要素があります。" & vbNewLine & _
          "ﾍﾟｰｽﾄするﾀｲﾌﾟを指定してください" & vbNewLine & vbNewLine & _
          "はい : ﾘﾝｸの結果として(As Result With Link)" & vbNewLine & _
          "いいえ : 結果として(As Result)" & vbNewLine & _
          "キャンセル : マクロ中止"
    Dim PasteType As String
    Select Case MsgBox(Msg, vbQuestion + vbYesNoCancel)
        Case vbYes
            PasteType = "CATPrtResult"
        Case vbNo
            PasteType = "CATPrtResultWithOutLink"
        Case Else
            Exit Sub
    End Select
    
    KCL.SW_Start

    'Assy
    Dim TopDoc As ProductDocument: Set TopDoc = CATIA.Documents.Add("Product")
    
    Call ToProduct(TopDoc, LeafItems, PasteType)
    
    TopDoc.Product.Update
    
    Debug.Print "Time:" & KCL.SW_GetTime & "s"
    MsgBox "Done"
End Sub

'Productにﾍﾟｰｽﾄ
Private Sub ToProduct(ByVal TopDoc As ProductDocument, _
                      ByVal LeafItems As Collection, _
                      ByVal PasteType As String)
    Dim TopSel As Selection
    Set TopSel = TopDoc.Selection
    
    Dim BaseSel As Selection
    Set BaseSel = KCL.GetParent_Of_T(LeafItems(1), "PartDocument").Selection
    
    Dim Prods As Products
    Set Prods = TopDoc.Product.Products
    
    Dim Itm As AnyObject
    Dim TgtDoc As PartDocument
    Dim ProdsNameDic As Object: Set ProdsNameDic = KCL.InitDic()
    
    CATIA.HSOSynchronized = False
    
    For Each Itm In LeafItems
        If ProdsNameDic.Exists(Itm.Name) Then
            Set TgtDoc = ProdsNameDic.Item(Itm.Name)
        Else
            Set TgtDoc = Init_Part(Prods, Itm.Name)
            ProdsNameDic.Add Itm.Name, TgtDoc
        End If
        
        Call Preparing_Copy(BaseSel, Itm)
        With BaseSel
            .Copy
            .Clear
        End With
        
        With TopSel
            .Clear
            .Add TgtDoc.Part
            .PasteSpecial PasteType
        End With
    Next
    BaseSel.Clear
    TopSel.Clear
    CATIA.HSOSynchronized = True
End Sub

'ｺﾋﾟｰ要素を選択状態にする
Private Sub Preparing_Copy(ByVal Sel As Selection, ByVal Itm As AnyObject)
    Sel.Clear
    
    'Body
    If TypeName(Itm) = "Body" Then
        Sel.Add Itm
        Exit Sub
    End If
    
    'HybridBody
    Dim ShpsLst As Collection: Set ShpsLst = New Collection
    ShpsLst.Add Itm.HybridShapes
    
    Select Case TypeName(Itm)
        Case "HybridBody"
            Set ShpsLst = Get_All_HbShapes(Itm, ShpsLst)
        Case "OrderedGeometricalSet"
            Set ShpsLst = Get_All_OdrGeoSetShapes(Itm, ShpsLst)
    End Select
    
    Dim Shps As HybridShapes, Shp As HybridShape
    For Each Shps In ShpsLst
        For Each Shp In Shps
            Sel.Add Shp
        Next
    Next
End Sub

'指定時系列形状ｾｯﾄ以下の全てHybridShapesを取得
'再帰　かなり効率悪いかも
Private Function Get_All_OdrGeoSetShapes(ByVal OdrGeoSet As OrderedGeometricalSet, _
                                         ByVal Lst As Collection) As Collection
    Dim Child As OrderedGeometricalSet
    For Each Child In OdrGeoSet.OrderedGeometricalSets
        Lst.Add Child.HybridShapes
        If Child.OrderedGeometricalSets.Count > 0 Then
            Set Lst = Get_All_OdrGeoSetShapes(Child, Lst)
        End If
    Next
    Set Get_All_OdrGeoSetShapes = Lst
End Function

'指定形状ｾｯﾄ以下の全てHybridShapesを取得
'再帰　かなり効率悪いかも
Private Function Get_All_HbShapes(ByVal Hbdy As HybridBody, _
                                  ByVal Lst As Collection) As Collection
    Dim Child As HybridBody
    For Each Child In Hbdy.hybridBodies
        Lst.Add Child.HybridShapes
        If Child.hybridBodies.Count > 0 Then
            Set Lst = Get_All_HbShapes(Child, Lst)
        End If
    Next
    Set Get_All_HbShapes = Lst
End Function

'ﾙｰﾄで、空ではなく表示されているﾎﾞﾃﾞｨ・形状ｾｯﾄ取得
Private Function Get_LeafItemLst(ByVal Pt As Part) As Collection
    Set Get_LeafItemLst = Nothing
    
    Dim Sel As Selection: Set Sel = Pt.Parent.Selection
    Dim TmpLst As Collection: Set TmpLst = New Collection
    Dim I As Long

    Dim Filter As String
    Filter = "(CATPrtSearch.BodyFeature.Visibility=Shown " & _
            "+ CATPrtSearch.OpenBodyFeature.Visibility=Shown" & _
            "+ CATPrtSearch.MMOrderedGeometricalSet.Visibility=Shown),sel"
    
    CATIA.HSOSynchronized = False
    
    With Sel
        .Clear
        .Add Pt
        .Search Filter
        For I = 1 To .Count2
            TmpLst.Add .Item(I).Value
        Next
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
    If TmpLst.Count < 1 Then Exit Function
    
    Dim LeafHBdys As Object: Set LeafHBdys = KCL.InitDic()
    Dim Hbdy As AnyObject 'HybridBody & OrderedGeometricalSets
    For Each Hbdy In Pt.hybridBodies
        LeafHBdys.Add Hbdy, 0
    Next
    For Each Hbdy In Pt.OrderedGeometricalSets
        LeafHBdys.Add Hbdy, 0
    Next
    
    
    Dim Itm As AnyObject
    Dim Lst As Collection: Set Lst = New Collection
    For Each Itm In TmpLst
        Select Case TypeName(Itm)
            Case "Body"
                If Is_LeafBody(Itm) Then Lst.Add Itm
            Case Else 'HybridBody & OrderedGeometricalSets
                If Is_LeafHybridBody(Itm, LeafHBdys) Then Lst.Add Itm
        End Select
    Next
    If Lst.Count < 1 Then Exit Function
    
    Set Get_LeafItemLst = Lst
End Function

'ﾙｰﾄのﾎﾞﾃﾞｨで中身が有るか?
Private Function Is_LeafBody(ByVal Bdy As Body) As Boolean
    Is_LeafBody = Bdy.InBooleanOperation = False And Bdy.Shapes.Count > 0
End Function

'ﾙｰﾄの形状ｾｯﾄで中身が有り可視か?As HybridBody
'prm:Hbdy - HybridBody & OrderedGeometricalSets
Private Function Is_LeafHybridBody(ByVal Hbdy As AnyObject, _
                                   ByVal Dic As Object) As Boolean
    Is_LeafHybridBody = False
    If Not Dic.Exists(Hbdy) Then Exit Function
    
    CATIA.HSOSynchronized = False
    
    Dim Sel As Selection
    Set Sel = KCL.GetParent_Of_T(Hbdy, "PartDocument").Selection
    
    Dim Cnt As Long
    
    With Sel
        .Clear
        .Add Hbdy
        .Search "Visibility=Shown,sel"
        Cnt = .Count2
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
    If Cnt > 1 Then Is_LeafHybridBody = True
End Function

'Part新作
Private Function Init_Part(ByVal Prods As Variant, _
                           ByVal PtNum As String) As PartDocument
    Dim Prod As Product
    On Error Resume Next
        Set Prod = Prods.AddNewComponent("Part", PtNum)
    On Error GoTo 0
    Set Init_Part = Prods.Item(Prods.Count).ReferenceProduct.Parent
End Function

・履歴有りのPartﾌｧｲﾙでも、それなりの処理を行います。

・ﾎﾞﾃﾞｨ･形状ｾｯﾄ･時系列形状ｾｯﾄでTreeのﾙｰﾄ?に
　ぶら下がって、表示されているもののみが対象です。(ｽｹｯﾁは対象外）

・元ﾃﾞｰﾀの形状ｾｯﾄ･時系列形状ｾｯﾄが階層状になっている
　ものは、全て同一ﾚﾍﾞﾙでﾍﾟｰｽﾄされます。

・ﾎﾞﾃﾞｨ等の名前が同一場合、同一のPartに取り込まれます。

・ﾎﾞﾃﾞｨ内に入っている形状ｾｯﾄ等、素直じゃない階層は
　見捨ててます。

・ﾊｲﾌﾞﾘｯﾄﾞﾃﾞｻﾞｲﾝは、未ﾃｽﾄです。

・ﾍﾟｰｽﾄする際は "ﾘﾝｸの結果として"　"結果として"　が選べます。

"ﾘﾝｸの結果として"　が可能になるようにしたかったので、
こだわりました。　支給ﾌｧｲﾙの差し替えが出来るような気がしたので。
(ﾘﾝｸを切るのは何時でも出来ますし)

手元に大き目のﾃﾞｰﾀが無かった為、GrabCADからお借りしました。
GrabCAD - CAD library
この方、日本人なんですよね。

お借りしたﾃﾞｰﾀで試しました。

結局、保存はしてません･･･。ﾌｧｲﾙ名まで手動でやろうとすると手間だよなぁ。

2017-10-04

Treeの順番を取得したい

CATIA_V5 VBA

Partで、このような状態でルート?のTreeにぶら下がっているものを
見た目の順番通りに取得したいのですが、方法がわかりません。

f:id:kandennti:20171004115141p:plain

Bodyだけなら順番通りに取得できます。　形容ｾｯﾄだけでも同様。
Bodyと形状ｾｯﾄ（や時系列形状ｾｯﾄ）が混合していた場合、
個別のものを順番通りに取得できるのですが、見た目通りには
ならないです。

Selection.Searchで出来るのかな?

2017-10-03

1つのPartからBody毎にしたProductを作り出す

CATIA_V5 VBA

ﾀｲﾄﾙの日本語が怪しいのですが、要はこちらのｺﾏﾝﾄﾞで
Assy　→　Part　にしたものを、再度Assy状態にしたい　と言うことです。

CATProductからCATPartを作成 | CATIAの小技

このｺﾏﾝﾄﾞは古いﾘﾘｰｽでは表側に無く、裏ｺﾏﾝﾄﾞだったんですよね。
"ﾃﾞｰﾀを軽くして客先に支給したい" "ﾉｳﾊｳの流出防止の為"　等
ｲﾛｲﾛと理由はあるかと思いますが、少なくても干渉ﾁｪｯｸは
Assy状態の方が楽ですね。

で、Part→Productにする為のﾏｸﾛは、恐らく世間にもあると思います。
が、Freeであるものかどうかは不明です。
(僕は見つけられませんでした)

ﾎﾞﾃﾞｨだけですが、ﾏｸﾛを作ってみました。

'vba
'PartからProductﾃｽﾄ

Option Explicit

Sub CATMain()
    Dim ActDoc As PartDocument
    Set ActDoc = CATIA.ActiveDocument
    
    Dim ActPath As Variant
    ActPath = Array(ActDoc.FullName)
    
    Dim TopDoc As ProductDocument
    Set TopDoc = CATIA.Documents.Add("Product")
    
    Dim Prods As Products
    Set Prods = TopDoc.Product.Products
    
    Dim Sel As Selection
    Set Sel = TopDoc.Selection
    
    Dim BeforePDoc As PartDocument
    Set BeforePDoc = Include_Part(Prods, ActPath)
    
    Dim Pt As Part
    Set Pt = BeforePDoc.Part
    
    Dim LeafBodies As Collection
    Set LeafBodies = Get_LeafBodyLst(Pt.Bodies)
    
    Dim Bdy As Body
    Dim NewPDoc As PartDocument
    For Each Bdy In LeafBodies
        Set NewPDoc = Init_Part(Prods, Bdy.Name)
        With Sel
            .Clear
            .Add Bdy
            .Copy
            .Clear
            .Add NewPDoc.Part
            .PasteSpecial "CATPrtResultWithOutLink" '"CATPrtResult"
        End With
        NewPDoc.Part.Update
    Next
    
    With Sel
        .Clear
        .Add Prods.Item(1)
        .Delete
    End With
End Sub

'ﾙｰﾄで空ではないﾎﾞﾃﾞｨ取得
Private Function Get_LeafBodyLst(ByRef Bdys As Bodies) As Collection
    Set Get_LeafBodyLst = Nothing
    Dim Bdy As Body
    Dim Lst As Collection: Set Lst = New Collection
    For Each Bdy In Bdys
        If Bdy.InBooleanOperation = False And Bdy.Shapes.Count > 0 Then
            Lst.Add Bdy
        End If
    Next
    If Lst.Count < 1 Then Exit Function
    Set Get_LeafBodyLst = Lst
End Function

Private Function Init_Part(ByRef Prods As Variant, _
                           ByVal PtNum As String) As PartDocument
    Call Prods.AddNewComponent("Part", PtNum)
    Set Init_Part = Prods.Item(Prods.Count).ReferenceProduct.Parent
End Function

Private Function Include_Part(ByRef Prods As Variant, _
                              ByVal Path As Variant) As PartDocument
    Call Prods.AddComponentsFromFiles(Path, "All")
    Set Include_Part = Prods.Item(Prods.Count).ReferenceProduct.Parent
End Function

何てことはありません。ひたすらｺﾋﾟﾍﾟしているだけなので。
例外処理等、細かな事はしていませんので、たったこれだけです。

実は、悩んでいるのはここからなんです。
このﾏｸﾛでは、新たに作成したPartやProductは保存していません。
各Partは、元のBody名で保存するのがスジだろうと思うのですが、
困ったことに日本語が含まれている可能性が有り、CATIA V5では
日本語ファイル名はNGだからです。

そこでカタカナをローマ字に変換する手法や関数が無いのか？
調べては見たのですが・・・

・力技っぽいもの(ちょっと遅そう)
かなローマ字変換ユーザー関数 - ExcelとかVBAとかの練習帳

・カタカナをローマ字に変換は無いものの、流用出来そうな物
文字種変換〔StrConv〕（WSH）

・カタカナを探し出す方法
正規表現でカタカナを検索 | inside of tactsystem

ん～完全でなくても良いんですが、どれもこれも個人的には響かなかったです。
（半角ｶﾀｶﾅが、更に扱いを悪くしているような･･･）
正攻法なら正規表現なのですが、分厚い本が出版できるほどの
奥深いものなので、僕には理解が出来ないです。

何か良い方法無いでしょうかね？

2017-09-29

Bodyの穴っぽい部分に点を作成

CATIA_V5 VBA KCL

業務上欲しくなったので、久々にCATIAのﾏｸﾛを作成しました。

穴あけ加工をCAMで作る際、Space-eでは穴位置となる点が
欲しかったので、こちらのﾏｸﾛをかなり前に作成しました。
指定した平面から、穴の中心点を作成する1 - C#ATIA

本来であれば、3Dの形状から穴位置と深さを取得した上で
ﾊﾞｧｰっと作りたいのが本音です。面倒なので・・・。

Space-eにもそれっぽい機能がある事を薄々は知っていたの
ですが、ｻﾎﾟｰﾄさんに相談し試したものの、打率が悪く
処理もｲﾏｲﾁ(ﾀﾞﾒならﾀﾞﾒとさっさと返してきて欲しい)
最終的には、出来上がる工程がこちらの運用とちょっと
異なる為、断念しました。

PowerMillの穴あけは、3Dの形状から穴位置と深さを取得
出来るのですが、こちらもちょっと馴染めず諦め、
Space-eで利用しやすいようCATIA側で何とかしてみようかな？
と行き着きました。（結論から書くと点を作成するだけです）

金型をﾓﾃﾞﾘﾝｸﾞする際、加工することを想定し(邪魔になるので)
穴はﾓﾃﾞﾘﾝｸﾞしない会社を知っているのですが、うちもそれに
近い状況です。
ｴｼﾞｪｸﾀﾋﾟﾝの穴はﾓﾃﾞﾙ内に無いのですが、裏からの逃がし穴は
ﾓﾃﾞﾘﾝｸﾞして有ります。
f:id:kandennti:20170929185811p:plain
緑色が製品側で、黄色が逃がし穴です。
(穴の先端が平らなのは、穴ｺﾏﾝﾄﾞじゃないからです。･･･僕が
ﾓﾃﾞﾙを作っているわけじゃないので。)

金型の裏面を指定する事で、
穴の入口、穴深さの位置、表まで貫通しきった位置
の3ヶ所の穴中心位置に点を作成します。

'vba CreateCenterPoint_ver0.0.2  using-'KCL0.0.10'
'個人的に欲しかったもの

Option Explicit

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    '面選択
    Dim Msg$
    Msg = "穴位置となる面を選択して下さい : ESCｷｰ 終了"
    Dim TgtFaceElm As SelectedElement
    Set TgtFaceElm = KCL.SelectElement(Msg, "PlanarFace")
    If KCL.IsNothing(TgtFaceElm) Then Exit Sub
    
    Dim TgtFace As PlanarFace
    Set TgtFace = TgtFaceElm.Value
    
    'ﾎﾞﾃﾞｨ取得
    Dim TgtBody As Body
    Set TgtBody = KCL.GetParent_Of_T(TgtFace, "Body")
    If KCL.IsNothing(TgtFaceElm) Then
        MsgBox "ﾎﾞﾃﾞｨの面を選択する必要が有ります"
        Exit Sub
    End If
    
    'ﾓﾛﾓﾛ
    Dim Pt As Part
    Set Pt = KCL.GetParent_Of_T(TgtFace, "Part")
    
    Dim Fact As HybridShapeFactory
    Set Fact = Pt.HybridShapeFactory
    
    Dim Sel As Selection
    Set Sel = Pt.Parent.Selection
    
    Dim Dustbox As Collection '削除用
    Set Dustbox = New Collection
    
    '押し出し方向
    Dim Dir As HybridShapeDirection
    Set Dir = GetDirection(Pt, Fact, False) 'True)
    Dustbox.Add Dir
    
    '形状ｾｯﾄ
    Dim HBdyBase As HybridBody
    Set HBdyBase = InitHBdy(Pt, "HolesCenter")
    
    '中心取得
    Dim Cnts As Collection
    Set Cnts = GetCenter(Pt, Fact, Sel, TgtFaceElm.Value, HBdyBase)
    If KCL.IsNothing(Cnts) Then
        MsgBox "穴の中心は見つかりませんでした"
        Dustbox.Add HBdyBase
        GoTo SubEnd
    End If
    Dustbox.Add Cnts
    'Call DumpGeo(HBdyBase, Cnts) 'debug
    
    '直線
    Dim LinRefs As Collection
    Set LinRefs = GetLineRefs(Pt, Fact, Dir, Cnts, 10000#)
    Dustbox.Add LinRefs
    'Call DumpGeo(HBdyBase, LinRefs) 'debug
    
    '交差
    Dim IntRefs As Collection
    Set IntRefs = GetIntersectRefs(Pt, Fact, TgtBody, LinRefs)
    Dustbox.Add IntRefs
    'Call DumpGeo(HBdyBase, IntRefs) 'debug
    
    '交差ﾁｪｯｸ
    If Not IsInValue(IntRefs) Then
        MsgBox "穴の中心は見つかりませんでした"
        Dustbox.Add HBdyBase
        GoTo SubEnd
    End If
    
    '直線の終点
    Dim FarRefs As Collection
    Set FarRefs = GetPntFarRefs(Pt, Fact, LinRefs)
    Dustbox.Add FarRefs
    'Call DumpGeo(HBdyBase, FarRefs) 'debug
    
    '近傍
    Dim Nears As Collection
    Set Nears = GetNear(Pt, Fact, IntRefs, Cnts)
    'Call DumpGeo(HBdyBase, Nears) 'debug
    
    '遠方
    Dim Fars As Collection
    Set Fars = GetNear(Pt, Fact, IntRefs, FarRefs)
    'Call DumpGeo(HBdyBase, Fars) 'debug
    
    '作成
    Call ToHybridBody(HBdyBase, Pt, Fact, IntRefs, Cnts, Nears, Fars)
    Pt.UpdateObject HBdyBase
    
SubEnd:
    'ｺﾞﾐ処理
    Call Disposal(Dustbox, Fact, Sel)
    
    MsgBox "Done"
End Sub

'全てNothingﾁｪｯｸ
Private Function IsInValue(ByVal Lst As Collection) As Boolean
    IsInValue = True
    Dim v As Variant
    For Each v In Lst
        If Not (v Is Nothing) Then Exit Function
    Next
    IsInValue = False
End Function

'ｺﾞﾐ処理
Private Sub Disposal(ByRef Lst, _
                     ByVal Fact As HybridShapeFactory, _
                     ByVal Sel As Selection)
    On Error Resume Next
        Dim v1, v2
        For Each v1 In Lst
            Select Case TypeName(v1)
                Case "Collection"
                    For Each v2 In v1
                        Fact.DeleteObjectForDatum v2
                    Next
                Case "HybridBody"
                    Call DelItem(Sel, v1)
                Case Else
                    Fact.DeleteObjectForDatum v1
            End Select
        Next
    On Error GoTo 0
End Sub

'削除
Private Sub DelItem(ByVal Sel As Selection, ByVal itm As Variant)
    Dim i&
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        .Add itm
        .Delete
    End With
    CATIA.HSOSynchronized = True
End Sub

'階層作って形状ｾｯﾄに代入
Private Sub ToHybridBody(ByVal Hbdy As HybridBody, _
                         ByVal Pt As Part, _
                         ByVal Fact As HybridShapeFactory, _
                         ByVal IntRefs As Collection, _
                         ByVal Btms As Collection, _
                         ByVal Mids As Collection, _
                         ByVal Tops As Collection)
    Dim TopHbdy As HybridBody: Set TopHbdy = InitHBdy(Hbdy, "Top")
    Dim MidHbdy As HybridBody: Set MidHbdy = InitHBdy(Hbdy, "Mid")
    Dim BtmHbdy As HybridBody: Set BtmHbdy = InitHBdy(Hbdy, "Btm")
    Dim i&
    For i = 1 To IntRefs.Count
        If KCL.IsNothing(IntRefs.Item(i)) Then GoTo Continue_For
        TopHbdy.AppendHybridShape Tops.Item(i)
        MidHbdy.AppendHybridShape Mids.Item(i)
        BtmHbdy.AppendHybridShape Fact.AddNewPointDatum(Btms.Item(i))
Continue_For:
    Next
End Sub

'形状ｾｯﾄ
Private Function InitHBdy(ByVal Parent, ByVal Name$)
    Dim Hb As HybridBody
    Set Hb = Parent.HybridBodies.Add()
    Hb.Name = Name
    Set InitHBdy = Hb
End Function

'近傍
Private Function GetNear(ByVal Pt As Part, _
                         ByVal Fact As HybridShapeFactory, _
                         ByVal IntRefs As Collection, _
                         ByVal PntRefs As Collection) As Collection
    Dim i&
    Dim Near As HybridShapeNear, Ref As Reference, Pnt As AnyObject
    Dim Nears As Collection: Set Nears = New Collection
    For i = 1 To IntRefs.Count
        If KCL.IsNothing(IntRefs.Item(i)) Then
            Nears.Add Nothing
            GoTo Continue_For
        End If
        Set Near = Fact.AddNewNear(IntRefs.Item(i), PntRefs.Item(i))
        Pt.UpdateObject Near
        Set Ref = Pt.CreateReferenceFromGeometry(Near)
        Set Pnt = Fact.AddNewPointDatum(Ref)
        Nears.Add Pnt
Continue_For:
    Next

    Set GetNear = Nears
End Function

'AddNewFarが無い為対策用の点
Private Function GetPntFarRefs(ByVal Pt As Part, _
                               ByVal Fact As HybridShapeFactory, _
                               ByVal LinRefs As Collection) As Collection
    Dim Pnt As HybridShapePointOnCurve, Ref As Reference
    Dim FarRefs As Collection: Set FarRefs = New Collection
    For Each Ref In LinRefs
        Set Pnt = Fact.AddNewPointOnCurveFromPercent(Ref, 1#, False)
        Pt.UpdateObject Pnt
        FarRefs.Add Pt.CreateReferenceFromGeometry(Pnt)
    Next
    
    Set GetPntFarRefs = FarRefs
End Function

'交差
Private Function GetIntersectRefs(ByVal Pt As Part, _
                                  ByVal Fact As HybridShapeFactory, _
                                  ByVal Bdy As Body, _
                                  ByVal LinRefs As Collection) As Collection
    Dim BdyRef As Reference
    Set BdyRef = Pt.CreateReferenceFromGeometry(Bdy)
    
    On Error Resume Next
    
    Dim LinRef As AnyObject, Intsect As HybridShapeIntersection
    Dim IntRefs As Collection: Set IntRefs = New Collection
    For Each LinRef In LinRefs
        Set Intsect = Fact.AddNewIntersection(BdyRef, LinRef)
        Intsect.PointType = 0
        Pt.UpdateObject Intsect
        If Err.Number = 0 Then
            IntRefs.Add Pt.CreateReferenceFromGeometry(Intsect)
        Else
            IntRefs.Add Nothing
            'Fact.DeleteObjectForDatum Intsect'これNG
        End If
    Next
    
    On Error GoTo 0
    
    Set GetIntersectRefs = IntRefs
End Function

'直線
Private Function GetLineRefs(ByVal Pt As Part, _
                             ByVal Fact As HybridShapeFactory, _
                             ByVal Dir As HybridShapeDirection, _
                             ByVal Pnts As Collection, _
                             ByVal Leng As Double) As Collection
    Dim Pnt As AnyObject, PntRef As Reference
    Dim LineRefs As Collection: Set LineRefs = New Collection
    Dim Lin As HybridShapeLinePtDir, LinRef As Reference
    For Each Pnt In Pnts
        Set PntRef = Pt.CreateReferenceFromGeometry(Pnt)
        Set Lin = Fact.AddNewLinePtDir(PntRef, Dir, 0#, Leng, False)
        Pt.UpdateObject Lin
        LineRefs.Add Pt.CreateReferenceFromGeometry(Lin)
    Next
    Set GetLineRefs = LineRefs
End Function

'押し出し方向
'SelectFG : True-ﾕｰｻﾞｰ指定座標系　False-PartのXYPlane
Private Function GetDirection(ByVal Pt As Part, _
                              ByVal Fact As HybridShapeFactory, _
                              ByVal SelectFG As Boolean) As HybridShapeDirection
    Set GetDirection = Nothing
    Dim Ref As Reference
    If SelectFG Then
        Dim Msg$
        Msg = "ﾁｪｯｸ方向をZ軸とする座標系を選択して下さい : ESCｷｰ 終了"
        Dim Axis As AxisSystem
        Set Axis = KCL.SelectItem(Msg, "AxisSystem")
        If KCL.IsNothing(Axis) Then Exit Function
        Set Ref = Axis.ZAxisDirection
    Else
        Set Ref = Pt.CreateReferenceFromGeometry(Pt.OriginElements.PlaneXY)
    End If
    Set GetDirection = Fact.AddNewDirection(Ref)
End Function

'中心点
Private Function GetCenter(ByVal Pt As Part, _
                           ByVal Fact As HybridShapeFactory, _
                           ByVal Sel As Selection, _
                           ByVal FaceRef, _
                           ByVal Hbdy As HybridBody) As Collection
    Set GetCenter = Nothing
    
    Dim Ext As HybridShapeExtract
    Set Ext = Fact.AddNewExtract(FaceRef)
    With Ext
        .PropagationType = 3
        .ComplementaryExtract = False
        .IsFederated = False
    End With
    Call Pt.UpdateObject(Ext)
    
    Hbdy.AppendHybridShape Ext
    
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        .Add Ext
        .Search "Topology.CGMEdge,sel"
    End With
    
    Dim i&, Edges As Collection
    Set Edges = New Collection
    For i = 1 To Sel.Count
        Edges.Add Sel.Item(i)
    Next
    Sel.Clear
    CATIA.HSOSynchronized = True
    
    If Edges.Count < 1 Then GoTo Exit_Func
    
    On Error Resume Next
    
    Dim EgElm As AnyObject, Cnt As AnyObject, Pnt As AnyObject, Ref As Reference
    Dim Pnts As Collection: Set Pnts = New Collection
    For Each EgElm In Edges
        Set Cnt = Fact.AddNewPointCenter(EgElm.Reference)
        Pt.UpdateObject Cnt
        If KCL.IsNothing(Cnt) Then GoTo Continue_ForEach
        Set Ref = Pt.CreateReferenceFromGeometry(Cnt)
        Set Pnt = Fact.AddNewPointDatum(Ref)
        Pt.UpdateObject Pnt
        Fact.DeleteObjectForDatum Cnt
        If KCL.IsNothing(Pnt) Then GoTo Continue_ForEach
        If Not Lst_Contains(Pnts, Pnt) Then Pnts.Add Pnt
Continue_ForEach:
    Next
        
    On Error GoTo 0
    
    If Pnts.Count < 1 Then GoTo Exit_Func
    Set GetCenter = Pnts
    
Exit_Func:
    Fact.DeleteObjectForDatum Ext
End Function

'重複ﾁｪｯｸ
Private Function Lst_Contains(ByVal Lst As Collection, _
                              ByVal Value As AnyObject) As Boolean
    Lst_Contains = True
    Dim itm As AnyObject
    For Each itm In Lst
        If itm Is Value Then Exit Function
    Next
    Lst_Contains = False
End Function

'ﾃﾞﾊﾞｯｸﾞ用
Private Sub DumpGeo(ByVal Hbdy As HybridBody, ByVal Lst As Collection)
    Dim Oj As AnyObject
    If TypeName(Lst.Item(1)) = "Reference" Then
        Dim Fact As HybridShapeFactory
        Set Fact = KCL.GetParent_Of_T(Hbdy, "Part").HybridShapeFactory
        For Each Oj In Lst
            If Not KCL.IsNothing(Oj) Then
                Hbdy.AppendHybridShape Fact.GSMGetObjectFromReference(Oj)
            End If
        Next
    Else
        For Each Oj In Lst
            If Not KCL.IsNothing(Oj) Then
                Hbdy.AppendHybridShape Oj
            End If
        Next
    End If
End Sub

うっかりしていましたが、貫通穴には点が作成されません。

こんな感じです。

実は、交差を処理している辺りに一時的に作成したものが
上手く削除しきれていない為、CATDUAのｸﾘｰﾝ実行すると
幾つもｺﾞﾐを処理されます。(ｲﾏｲﾁです)

他人には役立つとは思えませんが。

2017-09-25

3Dな曲線をエクスポートしてみる1

Fusion360API

修正すべき部分は多々ありますが、インポートに関しては
一区切り付け、エクスポートに取り掛かろうかと思ってます。

最初はインポート機能は、

・Fusion360でsirenの処理呼び出し
　↓
・siren側でFusion360用のPythonｺｰﾄﾞをﾌｧｲﾙに書き出し
　↓
・Fusion360で書き出したｽﾌﾟﾘｸﾄを実行

の手順で行おうと思っていたのですが、siren側で標準出力
した内容をFusion360側(と言いますか、python)で受け取れる事が
わかったので、ﾌｧｲﾙに書き出さずに処理させています。
ﾌｧｲﾙの書き出しや読み込みの時間的なﾛｽが無い為、
この方法の方が処理が速いだろうと思ったので。

同様にエクスポートも途中の処理をﾌｧｲﾙに書き出さずに
行いたいのですが・・・イマイチわかりません。

幸い、sirenはインタラクティブなシェルとして起動する方法があり、
これを立ち上げて、ｺﾏﾝﾄﾞをダラダラ流し込めば出来そうな
気がしているのですが。

試しに起動だけするｺｰﾄﾞです。

#FusionAPI_python
#Author-kantoku
#Description-exp_test1

# -*- coding: utf-8 -*-

import adsk.core, adsk.fusion, traceback, os

#-----設定------
this_dir = os.path.dirname(os.path.abspath(__file__))

#mruby_sirenパス
_siren_path = this_dir + r'\siren_0.14d_mingw64\bin\mirb.exe'

#ｲﾝﾎﾟｰﾄ用sirenｽﾌﾟﾘｸﾄパス
#_siren_script_path = this_dir + r'\siren_import.rb'
#-------------

def run(context):
    try:
        #start
        app = adsk.core.Application.get()
        ui = app.userInterface
        
        import subprocess
        subprocess.call(_siren_path)
        ui.messageBox('Done')
    except:
        if ui:
            ui.messageBox('ｴﾗｰ\n{}'.format(traceback.format_exc()))

一応、これだけでｲﾝﾀﾗｸﾃｨﾌﾞsirenの起動は出来ました。
ｺﾏﾝﾄﾞを送り込みたいのですが、

        subprocess.call(_siren_path)

では出来ないことは、何となくわかっています。

そこで、こんな感じに修正してみました。

 ・・・
        import subprocess
        
        proc = subprocess.Popen(_siren_path, 
                                stdin=subprocess.PIPE,
                                stdout=subprocess.PIPE)
        proc.communicate('print("hoge")')

ｲﾝﾀﾗｸﾃｨﾌﾞsirenが起動しているようにも見えるものの、何も
受け付けてもらえず、Fusion360側ではｴﾗｰとなってしまいます。

と言うところで、つっかえています・・・。