C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

2つのｻｰﾌｪｽ郡の最短距離を取得する

CATIA_V5 VBA

個人的には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

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