クリックしたｽｹｯﾁ点にHVの拘束を付ける

何となく、近い将来必要に迫られる気がしたので、作りました。
スケッチャーWB時のみ、クリックしたスケッチの点に原点からHとVの
拘束を付けます。

'vba 選択したｽｹｯﾁの点にHVの拘束を作成  using-'KCL0.0.12'

Sub CATMain()
    'ﾜｰｸﾍﾞﾝﾁﾁｪｯｸ
    If Not CATIA.GetWorkbenchId = "CS0WKS" Then
        MsgBox "ｽｹｯﾁ作業中のみ使用できます"
        Exit Sub
    End If
    
    'ﾓﾛﾓﾛ取得
    Dim skt As Sketch
    Set skt = GetActiveSketch()
    
    Dim ax2d As Axis2D
    Set ax2d = skt.AbsoluteAxis
    
    Dim cons As Constraints
    Set cons = skt.Constraints
    
    Dim pt As Part
    Set pt = KCL.GetParent_Of_T(skt, "PartDocument").Part
    
    Dim refH As Reference
    Set refH = pt.CreateReferenceFromObject(ax2d.HorizontalReference)
    
    Dim refV As Reference
    Set refV = pt.CreateReferenceFromObject(ax2d.VerticalReference)
    
    '選択準備
    Dim sel As Variant ' Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    Dim filter As Variant
    filter = Array("Point2D")
    
    Dim msg As String
    msg = "点を選択 / ESC=ｷｬﾝｾﾙ"

    Dim refP As Reference
    
    '選択
    Do
        sel.Clear
        Select Case sel.SelectElement2(filter, msg, False)
            Case "Cancel", "Undo", "Redo"
                Exit Sub
        End Select
        Set refP = sel.Item(1).Reference
        Call InitConstraint(refP, refH, refV, cons)
    Loop
End Sub

'拘束作成
Private Sub InitConstraint(ByVal refP As Reference, _
                           ByVal refH As Reference, _
                           ByVal refV As Reference, _
                           ByVal cons As Constraints)
    Dim con(1) As Constraint
    With cons
        Set con(0) = .AddBiEltCst(catCstTypeDistance, refH, refP)
        Set con(1) = .AddBiEltCst(catCstTypeDistance, refV, refP)
    End With
    
    Dim i As Long
    For i = 0 To UBound(con)
        If Not con(i).Status = catCstStatusOK Then
            Call RemoveConstraint(con(i))
        End If
    Next
End Sub

'拘束削除
Private Sub RemoveConstraint(ByVal con As Constraint)
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    With sel
        .Clear
        .Add con
        .Delete
    End With
End Sub

'ｱｸﾃｨﾌﾞなｽｹｯﾁ取得
Private Function GetActiveSketch() As Sketch
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    Dim skt As Sketch
    
    With sel
        Call .Clear
        Call .Search("CATPrtSearch.Sketch,in")
        Set skt = .Item(1).value
        Call .Clear
    End With
    Set GetActiveSketch = skt
End Function