小さな線や面を削除する

久々のCatVBAです。

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

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).DisplayName
    Next
    Msg = "微少要素が" + CStr(SmallShapes.Count) + "個見つかりました" + _
          Join(DispNames, vbNewLine) + vbNewLine + "削除しますか?"
    
    If MsgBox(Msg, vbYesNo + vbQuestion) = vbNo Then: Exit Sub
    
    Dim Ref As Reference
    For Each Ref In SmallShapes
        Call HSFact.DeleteObjectForDatum(Ref)
    Next
    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(Ref)
                End If
            Case 5 'Surface
                If IsSmallArea(Ref) Then
                    Call SmallShapes.Add(Ref)
                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)
    
    Set SelectItem = IIf(IsNothing(SE), Empty, 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"
            Exit Function
    End Select
    Set SelectElement = Sel.Item(1)
    Sel.Clear
End Function

ﾏｸﾛ実行後、形状ｾｯﾄを指定する事で形状ｾｯﾄ内の小さな線や面を
削除します。(子の形状ｾｯﾄ内の要素も対象です。)
削除対象となるｻｲｽﾞは先頭付近の定数

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

で変更してください。

削除対象となる要素が参照元となっている場合は、参照元が無い状態と
なるので色々と不具合が発生します。
実質、他ﾌｫｰﾏｯﾄのﾃﾞｰﾀを受け入れた後に実行する事になるのかな?

追記です。
KCLを使用しないように書いたつもりだったのですが、使っていました。
不足していた、GetParent_Of_T関数を追加しました。

更に追記です。
SelectElement関数を追加しました。　個人的なﾗｲﾌﾞﾗﾘKCLを
使って書いてしまうため、ついつい忘れてしまいます。

追記です。
imihitoさんからご指摘頂いた部分を修正いたしました。
確かにこちらの方が自然ですね。
又、削除前に削除される要素名をﾒｯｾｰｼﾞﾎﾞｯｸｽで表示するように
しました。　但し、Msgboxで表示できる文字数に制限があり
削除される要素数が大量な場合、全てを表示できない事があります。