小さな線や面を非表示にし、ﾘﾈｰﾑする

こちらの続きです。
小さな線や面を削除する - C#ATIA

基本的に前回のｺｰﾄﾞを改造したものです。

'catvba  sample_Hide_Rename_SmallShape
'指定した形状ｾｯﾄ内の微少要素の削除

Private Const SmallLength = 0.01        '微少長さ 単位mm
Private Const SmallArea = 0.0000000001  '微少面積 単位m^2

Private SmallShapes As Collection       '削除要素
Private SpaWB As Workbench
Private HSFact As HybridShapeFactory
Private Pt As Part

Sub CATMain()
    '形状ｾｯﾄ選択
    Dim Msg$: Msg = "選択して下さい : ESCｷｰ 終了"
    Dim SI As AnyObject
    Dim Doc As Document: Set Doc = CATIA.ActiveDocument
    Dim HBody As HybridBody
    Set HBody = SelectItem(Msg, Array("HybridBody"))
    If IsNothing(HBody) Then Exit Sub
    
    '削除要素の検索
    Set Pt = GetParent_Of_T(HBody, "Part")
    Set SpaWB = Pt.Parent.GetWorkbench("SPAWorkbench")
    Set HSFact = Pt.HybridShapeFactory
    Set SmallShapes = New Collection
    Call GetSmallItem(HBody)
    
    If SmallShapes.Count < 1 Then
        MsgBox "微少要素は見つかりませんでした"
        Exit Sub
    End If
    
    '削除
    Dim I As Long
    Dim DispNames() As String: ReDim DispNames(SmallShapes.Count)
    For I = 1 To SmallShapes.Count
        DispNames(I) = SmallShapes.Item(I).Name
    Next
    Msg = "微少要素が" + CStr(SmallShapes.Count) + "個見つかりました" + _
          Join(DispNames, vbNewLine) + vbNewLine + "非表示にしﾘﾈｰﾑしますか?"
    
    If MsgBox(Msg, vbYesNo + vbQuestion) = vbNo Then: Exit Sub
    
    Dim Sel As Selection: Set Sel = GetParent_Of_T(HBody, "PartDocument").Selection
    Call Sel.Clear
    For I = 1 To SmallShapes.Count
        SmallShapes.Item(I).Name = "SmallShape" + CStr(I)
        Call Sel.Add(SmallShapes.Item(I))
    Next
    Call Sel.VisProperties.SetShow(catVisPropertyNoShowAttr)
    
    MsgBox "終了"
End Sub

'微少要素の取得
'SmallShapesｺﾚｸｼｮﾝに取得
Private Sub GetSmallItem(ByVal HB As HybridBody)
    Dim HSs As HybridShapes: Set HSs = HB.HybridShapes
    Dim HS As HybridShape
    Dim Ref As Reference
    For Each HS In HSs
        Set Ref = Pt.CreateReferenceFromObject(HS)
        Select Case HSFact.GetGeometricalFeatureType(Ref)
            Case 2, 3, 4 'Curve,Line,Circle
                If IsSmallLength(Ref) Then
                    Call SmallShapes.Add(HS)
                End If
            Case 5 'Surface
                If IsSmallArea(Ref) Then
                    Call SmallShapes.Add(HS)
                End If
        End Select
    Next
    
    '子の形状ｾｯﾄを検索
    Dim ChildHBs As HybridBodies: Set ChildHBs = HB.HybridBodies
    Dim ChildHB As HybridBody
    For Each ChildHB In ChildHBs
        Call GetSmallItem(ChildHB)
    Next
End Sub

'微少線
Private Function IsSmallLength(ByVal Ref As Reference) As Double
    Dim Leng As Double: Leng = SpaWB.GetMeasurable(Ref).Length
    IsSmallLength = Not (SmallLength < Leng)
End Function

'微少面
Private Function IsSmallArea(ByVal Ref As Reference) As Double
    Dim Area As Double: Area = SpaWB.GetMeasurable(Ref).Area
    IsSmallArea = Not (SmallArea < Area)
End Function

'選択
''' @param:Msg-ﾒｯｾｰｼﾞ
''' @param:Filter-選択ﾌｨﾙﾀｰ(指定無し時AnyObject)
''' @return:AnyObject
Public Function SelectItem(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As AnyObject
    'Dim SE As SelectedElement
    Set SE = SelectElement(Msg, Filter)
    If IsNothing(SE) Then
        Set SelectItem = SE
    Else
        Set SelectItem = SE.Value
    End If
    'Set SelectItem = IIf(IsNothing(SE), Nothing, SE.Value)
End Function

'Nothing 書き方に統一感が無い為
''' @param:OJ-Variant(Of Object)
''' @return:Boolean
Public Function IsNothing(ByVal Oj As Variant) As Boolean
    IsNothing = Oj Is Nothing
End Function

'T型のParent取得 Nameでのﾁｪｯｸも必要
''' @param:AOj-AnyObject
''' @param:T-String
''' @return:AnyObject
Public Function GetParent_Of_T(ByVal AOj As AnyObject, ByVal T$) As AnyObject
    If TypeName(AOj) = TypeName(AOj.Parent) And _
       AOj.Name = AOj.Parent.Name Then
        Set GetParent_Of_T = Nothing
        Exit Function
    End If
    If TypeName(AOj) = T Then
        Set GetParent_Of_T = AOj
    Else
        Set GetParent_Of_T = GetParent_Of_T(AOj.Parent, T)
    End If
End Function

'選択
''' @param:Msg-ﾒｯｾｰｼﾞ
''' @param:Filter-選択ﾌｨﾙﾀｰ(指定無し時AnyObject)
''' @return:SelectedElement
Public Function SelectElement(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As SelectedElement
    If IsEmpty(Filter) Then Filter = Array("AnyObject")
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Set SelectElement = Nothing
            Exit Function
    End Select
    Set SelectElement = Sel.Item(1)
    Sel.Clear
End Function

上手く動作しなかった部分も有ったので、差分ではなく丸ごと
再掲載です。

該当する要素を非表示しﾘﾈｰﾑ(SmallShapeXX)します。