参照かつ外部とのｽｹｯﾁ拘束を削除する

自分が作業して欲しくなったので突貫で作りました。

こんなｽｹｯﾁ1を作ります。
f:id:kandennti:20180905155613p:plain
続いて、こんなｽｹｯﾁ2を作ります。
f:id:kandennti:20180905155620p:plain
基本的にｽｹｯﾁ1が変更されても、ｽｹｯﾁ2の形状は影響は有りません。
但し、"ｵﾌｾｯﾄ.20" はｽｹｯﾁ1に対して参照の拘束が付いています。
まぁｸﾘｱﾗﾝｽを確認したい　とかです。

ここで問題になるのは、ｽｹｯﾁ1が削除される場合です。
こんな風になりますよね？
f:id:kandennti:20180905155627p:plain
”すべての子を削除” のチェックを外し、実行してしまうと
f:id:kandennti:20180905155633p:plain
まぁエラーになります。形状には影響無いので無視したいところ
なのですが。

要は
・参照の拘束
・外部との拘束
と言うことです。

で、この様なｽｹｯﾁ拘束を削除するマクロです。

'vba Part_RemoveExternalElmConst Ver0.0.1  using-'KCL0.0.12'  by Kantoku

Option Explicit

Private Const EXTERNAL_ELEMENT_NAME = "CATIAGeometry"

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute(Array("PartDocument")) Then Exit Sub

    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    'ｽｹｯﾁ取得
    Dim skts As Collection
    Set skts = GetSketchList(doc)
    If skts.count < 1 Then
        MsgBox "ｽｹｯﾁがありません!", vbExclamation
        Exit Sub
    End If
    
    '処理確認
    Dim msg As String
    msg = "個のｽｹｯﾁに対して処理します。宜しいですか?"
    If MsgBox(skts.count & msg, vbYesNo + vbQuestion) = vbNo Then Exit Sub
    
    '削除対象の拘束取得
    Dim del_lst As Collection
    Set del_lst = GetRemoveConstraintList(skts)
    
    If del_lst.count < 1 Then
        MsgBox "削除すべきｽｹｯﾁ拘束が有りません!", vbExclamation
        Exit Sub
    End If
    
    '削除
    Dim cnt As Long
    cnt = RemoveConstraint(del_lst)
    
    'done
    doc.Part.Update
    MsgBox cnt & "個のｽｹｯﾁ拘束を削除しました"

End Sub

'ﾘｽﾄ内拘束の削除
Private Function RemoveConstraint(ByVal cons As Collection) As Long
    RemoveConstraint = cons.count
    
    Dim sel As Selection
    Set sel = KCL.GetParent_Of_T(cons(1), "PartDocument").Selection
    
    CATIA.HSOSynchronized = False
    
    sel.Clear
    
    Dim con As Constraint
    For Each con In cons
        sel.Add con
    Next
    sel.Delete
    sel.Clear
    
    CATIA.HSOSynchronized = True
End Function

'削除対象拘束ﾘｽﾄ
'条件:参照ﾁｪｯｸON & 外部要素との拘束
Private Function GetRemoveConstraintList(ByVal skts As Collection) As Collection
    Dim lst As Collection
    Set lst = New Collection
    
    Dim skt As Sketch
    Dim con As Constraint
    For Each skt In skts
        For Each con In skt.Constraints
            Debug.Print con.Name & " : " & CStr(con.Mode)
            If con.Mode = catCstModeDrivingDimension Then GoTo continue
            If Not HasExternalElementConstraint(con) Then GoTo continue
            
            lst.Add con
continue:
        Next
    Next
    
    Set GetRemoveConstraintList = lst
End Function

'ﾄﾞｷｭﾒﾝﾄ内のｽｹｯﾁﾘｽﾄ
Private Function GetSketchList(ByVal doc As Document) As Collection
    Dim sel As Selection
    Set sel = doc.Selection
    
    CATIA.HSOSynchronized = False
    With sel
        .Clear
        .Search "CATPrtSearch.Sketch,all"
    End With
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim i As Long
    For i = 1 To sel.Count2
        lst.Add sel.Item2(i).Value
    Next
    
    sel.Clear
    CATIA.HSOSynchronized = True
    
    Set GetSketchList = lst
End Function

'自身のｽｹｯﾁ要素以外との拘束か?
Private Function HasExternalElementConstraint(ByVal con As Constraint) As Boolean
    HasExternalElementConstraint = True
    
    Dim elm As AnyObject
    Dim idx As Long
    idx = 0
    
    On Error Resume Next
    
    Do While Err.Number = 0
        Err.Number = 0
        idx = idx + 1
        Set elm = con.GetConstraintElement(idx)
        If InStr(elm.Name, EXTERNAL_ELEMENT_NAME) > 0 Then
            Exit Function
            
        End If
    Loop
    HasExternalElementConstraint = False
End Function