指定した要素の周囲要素を取得する3

前回は無意味だったので、結局素直に距離を測り判断します。
ﾘﾌﾚｰﾑｵﾝと検索でHitした要素だけの距離測定のため、全部の要素に
対して行うより短時間で済むはずです。

'vba sample_Get_Outskirt_Items ver0.03  using-'KCL'
'指定した要素(GSD)の周囲の要素を取得
Option Explicit
Const NearLength = 2# '周囲とする距離

Sub CATMain()
    'ｸﾘｱ
    Dim Doc As Document: Set Doc = CATIA.ActiveDocument
    Dim Sel As Selection: Set Sel = Doc.Selection
    Call Sel.Clear

    '言語別 "ﾘﾌﾚｰﾑ ｵﾝ" ｺﾏﾝﾄﾞ文字取得
    Dim ReframeOnCommand$
    ReframeOnCommand = GetReframeOnString()
    If ReframeOnCommand = vbNullString Then Exit Sub
    
    '選択
    Dim Msg$: Msg = "GSD要素を選択して下さい : ESCｷｰ 終了"
    Dim HShape As SelectedElement ' HybridShape
    Set HShape = KCL.SelectElement(Msg, Array("HybridShape"))
    If KCL.IsNothing(HShape) Then Exit Sub
    
    'ｽﾀｰﾄView
    Dim StartScene As Variant: StartScene = GetScene3D(GetViewPnt3D())
    
    'ﾘﾌﾚｰﾑ ｵﾝ の為の再選択
    Call Sel.Add(HShape.Value)
    Call CATIA.StartCommand(ReframeOnCommand)
    
    'ﾘﾌﾚｰﾑ ｵﾝし終わるまでの時間稼ぎ
    If MsgBox("これの周辺要素を取得しますか？", vbYesNo) = vbNo Then Exit Sub
    
    'ﾘﾌﾚｰﾑ ｵﾝ 要素取得
    Dim Items As Variant: Items = GetSearchItems()
    Debug.Print "Search:" + CStr(Sel.Count2)
    
    '指定距離外要素除外
    Call RemoveSelItem(Sel, GetFarItemsIdx(HShape, Items, NearLength))
    Debug.Print "Remove:" + CStr(Sel.Count2)
    
    '表示を戻す
    Call UpdateScene(StartScene)
    
    MsgBox CStr(Sel.Count2) + "個選択しました"
End Sub

'指定距離より遠い要素のｲﾝﾃﾞｯｸｽ取得
Private Function GetFarItemsIdx(ByRef SelElm As SelectedElement, ByRef AryElms As Variant, ByVal Lng#) As Collection
    Dim Ref As Reference: Set Ref = SelElm.Reference
    
    Dim SearchRef() As Variant: ReDim SearchRef(UBound(AryElms))
    Dim i&
    For i = 1 To UBound(AryElms)
        Set SearchRef(i) = AryElms(i).Reference
    Next
    
    Dim Pt As Part: Set Pt = SelElm.Document.Part
    Dim Mes As Measurable
    Set Mes = Pt.Parent.GetWorkbench("SPAWorkbench").GetMeasurable(Ref)
    Dim FarItems As Collection: Set FarItems = New Collection
    For i = UBound(AryElms) To 1 Step -1
        If Mes.GetMinimumDistance(SearchRef(i)) > Lng Then
            Call FarItems.Add(i)
        End If
    Next
    Set GetFarItemsIdx = FarItems
End Function

'ﾘｽﾄのｲﾝﾃﾞｯｸｽをを元に選択解除する
Private Sub RemoveSelItem(ByRef Sel As Selection, ByVal List As Collection)
    Dim Idx
    CATIA.HSOSynchronized = False
    For Each Idx In List
        Sel.Remove2 Idx
    Next
    CATIA.HSOSynchronized = True
End Sub

'検索の "画面上の表示" で取得
Private Function GetSearchItems() As Variant
    Dim Sel As Selection: Set Sel = CATIA.ActiveDocument.Selection
    CATIA.HSOSynchronized = False
    Sel.Clear
    Sel.Search "Type=*,scr"
    
    Dim Items() As Variant: ReDim Items(Sel.Count2)
    Dim i&
    For i = 1 To Sel.Count2
        Set Items(i) = Sel.Item2(i) '.Value
    Next
    CATIA.HSOSynchronized = True
    GetSearchItems = Items
End Function

'言語別ﾘﾌﾚｰﾑ ｵﾝｺﾏﾝﾄﾞ文字取得
Private Function GetReframeOnString() As String
    Select Case KCL.GetLanguage()
        Case "ja"
            GetReframeOnString = "ﾘﾌﾚｰﾑ ｵﾝ"
        Case "en"
            GetReframeOnString = "Reframe On"
        Case Else
            '日本語でﾒｯｾｰｼﾞ出して意味が有るのか?
            MsgBox "言語設定が、日本語か英語のみしか対応していません"
    End Select
End Function

'表示のUpdate
Private Sub UpdateScene(ByVal Scene As Variant)
    Dim Viewer As Viewer3D: Set Viewer = CATIA.ActiveWindow.ActiveViewer
    Dim VPnt3D As Variant 'Viewpoint3D
    Set VPnt3D = Viewer.Viewpoint3D
    
    Dim Ary As Variant
    Ary = GetRangeAry(Scene, 0, 2)
    Call VPnt3D.PutOrigin(Ary)
    
    Ary = GetRangeAry(Scene, 3, 5)
    Call VPnt3D.PutSightDirection(Ary)
    
    Ary = GetRangeAry(Scene, 6, 8)
    Call VPnt3D.PutUpDirection(Ary)
    
    VPnt3D.FieldOfView = Scene(9)
    VPnt3D.FocusDistance = Scene(10)
    
    Call Viewer.Update
End Sub

'Viewpoint3Dからｼｰﾝ取得
Private Function GetScene3D(ByVal ViewPnt3D As Viewpoint3D) As Variant
    Dim vp As Variant: Set vp = ViewPnt3D
    Dim SceneAry As Variant
    
    Dim origin(2) As Variant: Call vp.GetOrigin(origin)
    
    Dim sight(2) As Variant: Call vp.GetSightDirection(sight)
    SceneAry = JoinAry(origin, sight)
    
    Dim up(2) As Variant: Call vp.GetUpDirection(up)
    SceneAry = JoinAry(SceneAry, up)
    
    Dim FieldOfView(0) As Variant: FieldOfView(0) = vp.FieldOfView
    SceneAry = JoinAry(SceneAry, FieldOfView)
    
    Dim FocusDist(0) As Variant: FocusDist(0) = vp.FocusDistance
    GetScene3D = JoinAry(SceneAry, FocusDist)
End Function

'現状の視点取得
Private Function GetViewPnt3D() As Viewpoint3D
    Set GetViewPnt3D = CATIA.ActiveWindow.ActiveViewer.Viewpoint3D
End Function