C#ATIA

↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)

2つのサーフェス郡の最短距離を取得する

個人的にはGWまでに完成出来たつもりなのですが、世間はGWですね・・・。
タイトルが異なりますが、内容的には前回の続きです。

技術的なオブジェクト?1 - C#ATIA


最近得た知識から、思い付いたサンプルが出来ました。
同一Partファイル内の、異なる形状セットのサーフェス郡の最短距離を得る
マクロです。 言葉では判りにくい為こんな感じのデータを想定しています。
f:id:kandennti:20160429124935p:plain
画像では少ないのですが、形状セット1内の多数のサーフェスと形状セット2内の
多数のサーフェスとの最短距離が得られます。

過去にこちらでボディ-ボディ間の最短距離を求めました。
ボディ - ボディ の最短距離の測定3 - C#ATIA
あちらに記載しましたが、SPAWorkbenchの場合はReferenceを引数として
用意しなければならないのですが、形状セットはReferenceを取得する事が
出来ません。

その為、互いの形状セット内のサーフェス同士を総当りで測定する必要が
あるのですが、サーフェス数が多くなるにつれ処理時間が膨大になる事が
容易に想像できます。 (リフレームオンとズームと検索の"画面上の表示"等を
組み合わせれば、少し処理を少なく出来るかも知れませんが)

そこで前回のTechnologicalObjectを利用して測定する方法を
調べました。 サンプルコードはこちらです。

'vba GetMinDist_Surfaces
Option Explicit

Sub CATMain()
    '準備
    Dim Msg$
    If CATIA.Documents.Count < 1 Then
        MsgBox "CATPartファイルを開いてください": Exit Sub
    End If
    
    If Not IsType_Of_T(CATIA.ActiveDocument, "PartDocument") Then
        MsgBox "CATPartファイルのみ対応しています": Exit Sub
    End If
    
    If Not IsExists(CATIA.ActiveDocument.FullName) Then
        MsgBox "CATPartファイルを一度保存してください": Exit Sub
    End If
    
    If CATIA.ActiveDocument.Saved = False Then 'Not Ng
        Msg = "CATPartファイルが修正されている為" + vbNewLine + _
              "正しい結果が得られない可能性があります。" + vbNewLine + _
              "処理を続けますか?"
        If MsgBox(Msg, vbYesNo) = vbNo Then: Exit Sub
    End If
    
    Dim PDoc As PartDocument: Set PDoc = CATIA.ActiveDocument
    Dim Pt As Part: Set Pt = PDoc.Part
    
    '現状の表示所得
    Dim OriginalState As Object
    Set OriginalState = GetShowHide(GetLeafContainer(Pt))
    
    '一個目選択
    Msg = "一個目の形状セットを選択して下さい(ESC-キャンセル)"
    Dim FirstHBody As HybridBody
    Set FirstHBody = SelectHybridBody(Msg, OriginalState)
    If IsNothing(FirstHBody) Then Exit Sub
    
    '二個目選択
    Msg = "二個目の形状セットを選択して下さい(ESC-キャンセル)"
    Dim SecondHBody As HybridBody
    Set SecondHBody = SelectHybridBody(Msg, OriginalState, FirstHBody)
    If IsNothing(SecondHBody) Then Exit Sub
    
    CATIA.RefreshDisplay = False '効果薄いなぁ・・・
    
    '既存から
    Dim TempPDoc As PartDocument
    Set TempPDoc = InitFromPart(PDoc.FullName)
    Dim TempPath$: TempPath = TempPDoc.FullName
    Call WindowMin
    
    'Assy
    Dim AssyDoc As ProductDocument
    Set AssyDoc = InitAssy(Array(PDoc, TempPDoc))
    If IsNothing(AssyDoc) Then
        MsgBox "Productが作成出来ませんでした": Exit Sub
    End If
    Call WindowMin
    
    '一個目測定準備
    Call SetLeafHide(PDoc, GetShowHideList(OriginalState, catVisPropertyShowAttr), _
                     GetInternalName(FirstHBody))

    '二個目測定準備
    Call SetLeafHide(TempPDoc, GetShowHideList(OriginalState, catVisPropertyShowAttr), _
                     GetInternalName(SecondHBody))
                     
    '距離測定
    Dim DistAry As Variant
    DistAry = GetDistance(AssyDoc.Product, PDoc.Product, TempPDoc.Product)
    
    'Assy終わり
    Call AssyDoc.Close
    
    '既存から終わり
    Call TempPDoc.Close
    
    '削除
    If IsExists(TempPath) Then
        CATIA.FileSystem.DeleteFile (TempPath)
    End If
    
    '表示戻し
    Call SetShowHide(PDoc, GetShowHideList(OriginalState, catVisPropertyShowAttr), _
                     catVisPropertyShowAttr)
    Call SetShowHide(PDoc, GetShowHideList(OriginalState, catVisPropertyNoShowAttr), _
                     catVisPropertyNoShowAttr)
    
    CATIA.RefreshDisplay = True
    
    '結果
    Select Case True
        Case IsEmpty(DistAry)
            MsgBox "測定が出来ませんでした": Exit Sub
        Case DistAry(0) = 0
            MsgBox "接触または干渉しています"
        Case Else
            MsgBox "最短距離は" + CStr(DistAry(0)) + "mmです。"
    End Select
    
    '点
    Msg = "最短距離(または接触/干渉)となる部分に点を作成しますか?"
    If MsgBox(Msg, vbYesNo) = vbNo Then: Exit Sub
    
    Call FirstHBody.AppendHybridShape(InitPnt3D(Pt, GetRangeAry(DistAry, 1, 3)))
    Call SecondHBody.AppendHybridShape(InitPnt3D(Pt, GetRangeAry(DistAry, 4, 6)))
End Sub

'*****サポートな関数*****
'Prod間の距離
Private Function GetDistance(ByVal TopAssy As Product, _
                             ByVal Prod1 As Product, ByVal Prod2 As Product) As Variant
    GetDistance = Empty
    
    Dim Grps As Groups: Set Grps = TopAssy.GetTechnologicalObject("Groups")
    Dim Grp As Group: Set Grp = Grps.Add
    Call Grp.AddExplicit(Prod1)
    Call Grp.AddExplicit(Prod2)
    
    Dim Dists As Distances: Set Dists = TopAssy.GetTechnologicalObject("Distances")
    Dim Dist As Distance: Set Dist = Dists.Add
    Dist.FirstGroup = Grp
    Dist.Compute
    If Dist.IsDefined = 1 Then
        Dim MinDist(0) As Variant: MinDist(0) = Dist.Value
        Dim DistVar As Variant: Set DistVar = Dist
        Dim First(2) As Variant: Call DistVar.GetFirstPointCoordinates(First)
        GetDistance = JoinAry(MinDist, First)
        Dim Second(2) As Variant: Call DistVar.GetSecondPointCoordinates(Second)
        GetDistance = JoinAry(GetDistance, Second)
    End If
    Grps.Remove Grp
End Function

'最新のWindow最小化
Private Sub WindowMin()
    CATIA.Windows.Item(CATIA.Windows.Count).WindowState = catWindowStateMinimized
End Sub

'表示されているリスト取得
Private Function GetShowList(ByVal Dic As Object) As Variant
    GetShowList = GetShowHideList(Dic, catVisPropertyShowAttr)
End Function

'ディクショナリから表示/非表示を取得
Private Function GetShowHideList(ByVal Dic As Object, _
                                 ByVal enumShow As CatVisPropertyShow) _
                                 As Variant
    Dim Keys As Variant: Keys = Dic.Keys
    Dim Shows() As Variant: ReDim Shows(Dic.Count)
    Dim Idx&: Idx = -1
    Dim I&
    For I = 0 To Dic.Count - 1
        If Dic(Keys(I)) = enumShow Then
            Idx = Idx + 1
            Shows(Idx) = Keys(I)
        End If
    Next
    If Idx < 0 Then
        GetShowHideList = Empty: Exit Function
    End If
    ReDim Preserve Shows(Idx)
    GetShowHideList = Shows
End Function

'指定要素以外を非表示
Private Sub SetLeafHide(ByVal Doc As PartDocument, ByVal ConList As Variant, _
                        ByVal ShowItem$)
    Call SetShowHide(Doc, ConList, catVisPropertyNoShowAttr)
    Call SetShowHide(Doc, Array(ShowItem), catVisPropertyShowAttr)
End Sub

'配列要素を表示/非表示する
Private Sub SetShowHide(ByVal Doc As PartDocument, ByVal ShowList As Variant, _
                        ByVal enumShow As CatVisPropertyShow)
    If IsEmpty(ShowList) Then Exit Sub
    Dim Sel As Selection: Set Sel = Doc.Selection
    Dim Pt As Part: Set Pt = Doc.Part
    Dim I&, IntName$
    CATIA.HSOSynchronized = False
    Sel.Clear
    For I = 0 To UBound(ShowList)
        IntName$ = ShowList(I)
        Call Sel.Add(Pt.FindObjectByName(IntName))
    Next
    Call Sel.VisProperties.SetShow(enumShow)
    Sel.Clear
    CATIA.HSOSynchronized = True
End Sub

'既存から新作パート
Private Function InitFromPart(ByVal Path$) As PartDocument
    Dim NewName$: NewName = GetNewName(Path)
    Dim PDoc As PartDocument: Set PDoc = CATIA.Documents.NewFrom(Path)
    Call PDoc.SaveAs(NewName)
    Set InitFromPart = PDoc
End Function

'新作プロダクト
Private Function InitAssy(ByVal AryPDoc As Variant) As ProductDocument
    Set InitAssy = Nothing
    If Not IsArray(AryPDoc) Then Exit Function
    
    Dim AssyDoc As ProductDocument: Set AssyDoc = CATIA.Documents.Add("Product")
    Dim ProdsVar As Variant: Set ProdsVar = AssyDoc.Product.Products
    Dim PtsPathVar() As Variant: ReDim PtsPathVar(UBound(AryPDoc))
    Dim I&
    For I = 0 To UBound(AryPDoc)
        PtsPathVar(I) = AryPDoc(I).FullName
    Next
    On Error Resume Next
        Call ProdsVar.AddComponentsFromFiles(PtsPathVar, "All")
    On Error GoTo 0
    If Err.Number = 0 Then Set InitAssy = AssyDoc
    Err.Clear
End Function

'形状セット選択 ネスト深すぎ・・・
Private Function SelectHybridBody(ByVal Msg$, ByVal TrueList As Object, _
                                  Optional ByVal NgHBody As HybridBody) As HybridBody
    Dim SelHB As HybridBody, SelHB_InName$
    Do
        Set SelHB = SelectItem(Msg, Array("HybridBody"))
        If IsNothing(SelHB) Then
            Set SelectHybridBody = Nothing: Exit Function
        End If
        SelHB_InName = GetInternalName(SelHB)
        If TrueList.Exists(SelHB_InName) Then
            If Not IsNothing(NgHBody) Then
                If SelHB_InName = GetInternalName(NgHBody) Then
                    MsgBox "既に選択済みです"
                Else
                    If HasSurFace(SelHB) Then
                        Exit Do
                    Else
                        MsgBox "選択した形状セットには、サーフェスがありません"
                    End If
                End If
            Else
                If HasSurFace(SelHB) Then
                    Exit Do
                Else
                    MsgBox "選択した形状セットには、サーフェスがありません"
                End If
            End If
        Else
            MsgBox "Tree直下の形状セットを選択して下さい"
        End If
    Loop
    Set SelectHybridBody = SelHB
End Function

'サーフェスを所有しているか?
Private Function HasSurFace(ByVal HBody As HybridBody) As Boolean
    HasSurFace = False
    
    '直でShape有り
    Dim HShapes As HybridShapes: Set HShapes = HBody.HybridShapes
    If HShapes.Count > 0 Then
        Dim Pt As Part: Set Pt = GetParent_Of_T(HShapes.Item(1), "Part")
        Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
        Dim Sh As AnyObject
        For Each Sh In HShapes
            If Fact.GetGeometricalFeatureType(Sh) = 5 Then
                HasSurFace = True: Exit Function '発見
            End If
        Next
    End If
    
    'Surface無しor直でShape無し
    Dim HBsCount&: HBsCount = HBody.HybridBodies.Count
    If HBsCount > 0 Then
        Dim I&
        For I = 1 To HBsCount
            HasSurFace = HasSurFace(HBody.HybridBodies.Item(I))
            If HasSurFace Then Exit Function '既に発見済み
        Next
    End If
End Function

'表示/非表示取得
Private Function GetShowHide(ByVal Ary As Variant) As Object
    If Not IsArray(Ary) Then
        GetShowHide = Empty: Exit Function
    End If
    Dim Doc As Document: Set Doc = Ary(0).GetItem("ModelElement").Document
    Dim Sel As Selection: Set Sel = Doc.Selection
    Dim Vps As VisPropertySet: Set Vps = Sel.VisProperties
    Dim SHDic As Object: Set SHDic = InitDic
    Dim I&
    Dim ShowState As CatVisPropertyShow
    CATIA.HSOSynchronized = False
    For I = 0 To UBound(Ary)
        With Sel
            .Clear
            .Add Ary(I)
            Call Vps.GetShow(ShowState)
            SHDic.Add GetInternalName(Ary(I)), ShowState
        End With
    Next
    Sel.Clear
    CATIA.HSOSynchronized = True
    Set GetShowHide = SHDic
End Function

'Tree直下のボディと形状セット
Private Function GetLeafContainer(ByVal Pt As Part) As Variant
    Dim Bs As Variant: Bs = GetLeafBodies(Pt.Bodies)
    Dim HBs As Variant: HBs = GetLeafHybridBodies(Pt.HybridBodies)
    GetLeafContainer = JoinAry(Bs, HBs)
End Function

'Tree直下の形状セット
Private Function GetLeafHybridBodies(ByVal HBs As HybridBodies) As Variant
    If HBs.Count < 1 Then
        GetLeafHybridBodies = Empty: Exit Function
    End If
    
    Dim LHb() As Variant: ReDim LHb(HBs.Count - 1)
    Dim I&
    For I = 1 To HBs.Count
        Set LHb(I - 1) = HBs.Item(I)
    Next
    GetLeafHybridBodies = LHb
End Function

'Tree直下のボディ
Private Function GetLeafBodies(ByVal Bds As Bodies) As Variant
    Dim Lb() As Variant: ReDim Lb(Bds.Count)
    Dim LbCount&: LbCount = -1
    Dim Bd As Body
    For Each Bd In Bds
        If Bd.InBooleanOperation = False Then 'NotはNg
            LbCount = LbCount + 1
            Set Lb(LbCount) = Bd
        End If
    Next
    If LbCount < 0 Then
        GetLeafBodies = Empty
        Exit Function
    End If
    ReDim Preserve Lb(LbCount)
    GetLeafBodies = Lb
End Function

'点の作成
Private Function InitPnt3D(ByVal Pt As Part, ByVal Pos As Variant) As HybridShapePointCoord
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Dim Pnt As HybridShapePointCoord
    Set Pnt = Fact.AddNewPointCoord(Pos(0), Pos(1), Pos(2))
    Call Pt.UpdateObject(Pnt)
    Set InitPnt3D = Pnt
End Function


'*****汎用的な関数*****
'InternalName
Private Function GetInternalName(ByVal AOj As AnyObject) As String
    If IsNothing(AOj) Then
        GetInternalName = Empty: Exit Function
    End If
    GetInternalName = AOj.GetItem("ModelElement").InternalName
End Function

'選択
Private Function SelectItem(ByVal Msg$, ByVal Filter As Variant) As AnyObject
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SelectItem = Sel.Item(1).Value
    Sel.Clear
End Function

'T型のParent取得 Nameでのチェックも必要
Private Function GetParent_Of_T(ByVal AnyOj As AnyObject, ByVal t$) As AnyObject
    If TypeName(AnyOj) = TypeName(AnyOj.Parent) And _
       AnyOj.Name = AnyOj.Parent.Name Then
        Set GetParent_Of_T = Nothing
        Exit Function
    End If
    If TypeName(AnyOj) = t Then
        Set GetParent_Of_T = AnyOj
    Else
        Set GetParent_Of_T = GetParent_Of_T(AnyOj.Parent, t)
    End If
End Function

'型チェック
Private Function IsType_Of_T(ByVal AnyOj As AnyObject, ByVal t$) As Boolean
    IsType_Of_T = IIf(TypeName(AnyOj) = t, True, False)
End Function


'*****システムな関数*****
'Nothing 書き方に統一感が無い為
Private Function IsNothing(ByVal OJ As Variant) As Boolean
    IsNothing = OJ Is Nothing
End Function

'Scripting.Dictionary
Private Function InitDic() As Object
    Set InitDic = CreateObject("Scripting.Dictionary")
End Function


'*****配列な関数*****
'配列の連結
Private Function JoinAry(ByVal Ary1 As Variant, ByVal Ary2 As Variant)
    Select Case True
        Case Not IsArray(Ary1) And Not IsArray(Ary2)
            JoinAry = Empty: Exit Function
        Case Not IsArray(Ary1)
            JoinAry = Ary2: Exit Function
        Case Not IsArray(Ary2)
            JoinAry = Ary1: Exit Function
    End Select
    Dim StCount&: StCount = UBound(Ary1)
    ReDim Preserve Ary1(UBound(Ary1) + UBound(Ary2) + 1)
    Dim I&
    If IsObject(Ary2(0)) Then
        For I = StCount + 1 To UBound(Ary1)
            Set Ary1(I) = Ary2(I - StCount - 1)
        Next
    Else
        For I = StCount + 1 To UBound(Ary1)
            Ary1(I) = Ary2(I - StCount - 1)
        Next
    End If
    JoinAry = Ary1
End Function

'配列の抽出
Private Function GetRangeAry(ByVal Ary As Variant, StartIdx&, ByVal EndIdx&) As Variant
    If Not IsArray(Ary) Then Exit Function
    If EndIdx - StartIdx < 0 Then Exit Function
    If StartIdx < 0 Then Exit Function
    If EndIdx > UBound(Ary) Then Exit Function
    
    Dim RngAry() As Variant: ReDim RngAry(EndIdx - StartIdx)
    Dim I&
    For I = StartIdx To EndIdx
        RngAry(I - StartIdx) = Ary(I)
    Next
    GetRangeAry = RngAry
End Function

'配列のクローン
Private Function CloneAry(ByVal Ary As Variant) As Variant
    If Not IsArray(Ary) Then Exit Function
    GetRangeAry = GetRangeAry(Ary, 0, UBound(Ary))
End Function


'*****IOな関数*****
'FileSystemObject
Private Function GetFSO() As Object
    Set GetFSO = CreateObject("Scripting.FileSystemObject")
End Function

'パス/ファイル名/拡張子 分割
'Return: 0-Path 1-BaseName 2-Extension
Private Function SplitPathName(ByVal FullPath) As Variant
    Dim Path(2) As String
    With GetFSO
        Path(0) = .GetParentFolderName(FullPath)
        Path(1) = .GetBaseName(FullPath)
        Path(2) = .GetExtensionName(FullPath)
    End With
    SplitPathName = Path
End Function

'パス/ファイル名/拡張子 連結
Private Function JoinPathName(ByVal Path) As String
    If Not IsArray(Path) Then Stop '未対応
    If Not UBound(Path) = 2 Then Stop '未対応
    JoinPathName = Path(0) + "\" + Path(1) + "." + Path(2)
End Function

'ファイルの有無
Private Function IsExists(ByVal Path) As Boolean
    IsExists = GetFSO.FileExists(Path)
End Function

'重複しない名前取得
Private Function GetNewName(ByVal IgsPath) As String
    Dim Path As Variant
    Path = SplitPathName(IgsPath)
    Dim Ext$: Ext = ".CATPart"
    Dim NewPath$: NewPath = Path(0) + "\" + Path(1)
    If Not IsExists(NewPath + Ext) Then
        GetNewName = NewPath + Ext
        Exit Function
    End If
    Dim I&: I = 0
    Dim TempName$
    Do
        I = I + 1
        TempName = NewPath + "_" + CStr(I) + Ext
        If Not IsExists(TempName) Then
            GetNewName = TempName
            Exit Function
        End If
    Loop
End Function

えらく長くなってしまいました。
過去に記載した関数達も有り、そろそろライブラリのようなものを
用意しようかなぁ。

主な処理内容としては、
・2つの形状セットを指定
 ↓
・アクティブなPartファイルを元に「既存ファイルから新規作成」を作成
 ↓
・一時的なProductを作成し、2つのPartファイルを取り込み
 ↓
・2つの形状セット以外の形状セットとボディを非表示にする
 ↓
・「スペース・アナリシス」の「距離」コマンドで2つのPart間を測定
となっています。

「既存ファイルから新規作成」で作成したPartファイルは、InternalNameが
変更されないようなので、それを利用して表示/非表示のオブジェクトを
探し出しています。

InternalNameテスト - C#ATIA


「距離」コマンドについては前回の「GetTechnologicalObject」で
行っています。試したところ、「干渉」と「セクション作成」についても
マクロで利用できそうです。
f:id:kandennti:20160429125004p:plain

実行する際の幾つか注意点があります。
・修正されているPartファイルの場合、警告が出ます。
 (既存ファイルから新規作成を利用している為です)
f:id:kandennti:20160429125010p:plain

・選択する形状セットに制限を設けています。
f:id:kandennti:20160429125049p:plain
表示/非表示を簡素化するため、TopTreeに直接ぶら下がっている
形状セットしか選択できません。
「形状セット.1」-選択可能
「形状セット.2」-選択出来ません
「形状セット.3」-選択可
「形状セット.4」-選択出来ません(測定すべき要素が無い為)
「形状セット.5」-選択出来ません(サーフェスが無い為)

マクロ実行し測定されると最短距離、又は接触干渉を表示します。
f:id:kandennti:20160429125025p:plain
その後、以下のメッセージを表示します。(一緒に出せば良かったなぁ)
f:id:kandennti:20160429125056p:plain
「はい」を選択した場合、それぞれの形状セットの最後に点が作成
されます。
f:id:kandennti:20160429125102p:plain

マクロでこんな事できるんですね。需要有るか微妙ですが。
(恐らく僕は使わなそう・・・)