カレントビューの角度や生成スタイルの取得2

こちらの続きです。
カレントビューの角度や生成スタイルの取得 - C#ATIA

前回「IDやSuffixが関係してくると、もうちょっとややこしいです。」と書いた
ビュー名辺りのお話です。

こんな状態のデータです。

ここでこちらのコードを実行します。

'vba
Sub CATMain()
    
    Dim msg As String
    
    'ﾄﾞｷｭﾒﾝﾄ
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    'ｶﾚﾝﾄﾋﾞｭｰ
    Dim actVi As DrawingView
    Set actVi = dwDoc.Sheets.ActiveSheet.views.ActiveView
    
    'ﾋﾞｭｰ名変更
    actVi.Name = "HOGE"
    msg = "ﾋﾞｭｰ名 : " & actVi.Name
    
    MsgBox msg, , "** ｶﾚﾝﾄﾋﾞｭｰ情報 **"
    
End Sub

ビュー名が変わり、ビュー内のテキストも変更されます。

ビューのプロパティを見ると、式が利用されているようです。

（ビュー内のテキストの「1：1」は属性ﾘﾝｸかな？）

御質問頂いた内容は、Prefix・ID・Suffixを扱うと言う内容だと
思いましたので、これからが本題です。
IDとSuffixが空欄では味気ないので、こんな感じにして見ました。

こちらのマクロを実行します。

'vba
Sub CATMain()
    
    Dim msg As String
    
    'ﾄﾞｷｭﾒﾝﾄ
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    'ｶﾚﾝﾄﾋﾞｭｰ
    Dim actVi As DrawingView
    Set actVi = dwDoc.Sheets.ActiveSheet.views.ActiveView
    
    'ﾋﾞｭｰ名の取得
    Dim prefix As String, ident As String, suffix As String
    actVi.GetViewName prefix, ident, suffix
    
    MsgBox "Prefix:" & prefix & vbCrLf & _
           "Ident:" & ident & vbCrLf & _
           "Suffix:" & suffix
    
    'ﾋﾞｭｰ名の変更
    prefix = "PIYO"
    ident = " HUGA"
    suffix = " POYO"
    
    actVi.SetViewName prefix, ident, suffix
    
    MsgBox "Prefix:" & prefix & vbCrLf & _
           "Ident:" & ident & vbCrLf & _
           "Suffix:" & suffix
    
End Sub

一度Get～して、修正時はSet～です。実行後がこちら。

ん？Tree側のﾋﾞｭｰ名が変更されていません。　手動でビューのプロパティ
開いたり何らかのアクションを起こせば、正しく表示されるのですが･･･。
ビューのUpdateもダメ、RefreshDisplayもダメ、強制更新すれば良いのかも
知れませんが、重いデータで行うのは気が引けます。

イロイロとお手軽そうな操作で探すと、アクティブなビューを変更すると
正しい表示になったので、一時的にバックグラウンドをアクティブにし
再度元のビューをアクティブにするように変更しました。

・・・
    actVi.SetViewName prefix, ident, suffix
    
    '追加
    Dim vis As DrawingViews
    Set vis = dwDoc.Sheets.ActiveSheet.views

    vis.Item(2).Activate
    actVi.Activate
    'ここまで
    
    MsgBox "Prefix:" & prefix & vbCrLf & _
           "Ident:" & ident & vbCrLf & _
           "Suffix:" & suffix

End Sub

上手く行きました。

サーフェスの重心をDrawのﾃｰﾌﾞﾙに書き込む2

こちらの続きです。
サーフェスの重心をDrawのﾃｰﾌﾞﾙに書き込む - C#ATIA

ちょっとお望みの状態では無かった様で、修正しました。

'Drawからマクロをスタートし、Partのサーフェスを指定
'Drawにﾃｰﾌﾞﾙを新作し、重心位置を書き込む2

Option Explicit

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'ｻｰﾌｪｽ選択
    Dim msg As String
    msg = "重心を求めるｻｰﾌｪｽを指定してください / ESCキー ｷｬﾝｾﾙ"
    
    Dim elm As SelectedElement
    Set elm = SelectElement4(msg, msg, Array("HybridShape")) 'ここ修正
    
    '重心
    Dim cog As Variant
    cog = GetCog(elm.Value) 'ここ修正
    
    'ﾃｰﾌﾞﾙ作成
    Dim tb As DrawingTable
    Set tb = InitDrawTable
    
    'ﾃｰﾌﾞﾙに書き込み
    Call WriteTable(tb, elm.Value.Name, Join(cog, ",")) 'ここ修正
    
    'fin
    MsgBox "Done"

End Sub

'ﾃｰﾌﾞﾙ書き込み
Private Sub WriteTable( _
    ByVal tb As DrawingTable, _
    ByVal faceName As String, _
    ByVal cog As String)
    
    Call tb.SetCellString(1, 1, faceName)
    Call tb.SetCellString(1, 2, cog)

End Sub

'重心 -ﾓﾛﾓﾛ修正
Private Function GetCog( _
    ByVal hs As HybridShape) _
    As Variant
    
    Dim doc As PartDocument
    Set doc = GetParent_Of_T(hs, "PartDocument")
    
    Dim spa As Object
    Set spa = doc.GetWorkbench("SPAWorkbench")
    
    Dim pt As part
    Set pt = doc.part
    
    Dim ref As Reference
    Set ref = pt.CreateReferenceFromObject(hs)
    
    Dim mes As Variant ' Measurable
    Set mes = spa.GetMeasurable(ref)
    
    Dim cog(2) As Variant
    mes.GetCog cog
    
    GetCog = cog
    
End Function

'T型のParent取得 -追加
Private Function GetParent_Of_T( _
    ByVal aoj As AnyObject, _
    ByVal t As String) _
    As AnyObject
    
    Dim aojName As String
    Dim parentName As String
    
    On Error Resume Next
        aojName = aoj.Name
        parentName = aoj.Parent.Name
    On Error GoTo 0

    If typename(aoj) = typename(aoj.Parent) And _
       aojName = parentName 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

'ｻｰﾌｪｽか? -追加
Private Function IsSurface( _
    ByVal sp As HybridShape) _
    As Boolean
    
    Dim pt As part
    Set pt = GetParent_Of_T(sp, "Part")
    
    Dim fact As HybridShapeFactory
    Set fact = pt.HybridShapeFactory
    
    Dim ref As Reference
    Set ref = pt.CreateReferenceFromObject(sp)
    
    IsSurface = IIf(fact.GetGeometricalFeatureType(ref) = 5, True, False)
    
End Function

'SelectElement4 -ﾓﾛﾓﾛ修正
Private Function SelectElement4( _
    ByVal msg1 As String, _
    ByVal msg2 As String, _
    ByVal filter As Variant) _
    As SelectedElement
    
    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.selection
    Dim targetDoc As Variant 'Document 型指定Ng
    
    Do
        sel.Clear
        Select Case sel.SelectElement4(filter, msg1, msg2, _
                                       True, targetDoc)
            Case "Cancel", "Undo", "Redo"
                Exit Function
        End Select
        
        Dim tgtSel As selection
        Set tgtSel = targetDoc.selection
        
        Dim elm As SelectedElement
        Set elm = tgtSel.Item2(1)
        
        'ｻｰﾌｪｽﾁｪｯｸ
        If IsSurface(elm.Value) Then
            Exit Do
        Else
            MsgBox "ｻｰﾌｪｽﾀｲﾌﾟを選択してください!!"
        End If
    Loop
    
    Set SelectElement4 = elm
    
    sel.Clear
    tgtSel.Clear
End Function

'アクティブなビューにDrawﾃｰﾌﾞﾙの作成
Private Function InitDrawTable() _
    As DrawingTable
    
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    Dim vi As DrawingView
    Set vi = dwDoc.Sheets.ActiveSheet.views.ActiveView

    Set InitDrawTable = vi.Tables.Add( _
        -100#, _
        200#, _
        3, _
        2, _
        8#, _
        20#)
        
End Function
    
'ｴﾗｰ回避の為のﾄﾞｷｭﾒﾝﾄﾀｲﾌﾟﾁｪｯｸ
Private Function CanExecute( _
    ByVal docTypes As Variant) _
    As Boolean
    
    CanExecute = False
    
    If CATIA.Windows.Count < 1 Then
        MsgBox "ﾌｧｲﾙが開かれていません"
        Exit Function
    End If
    
    If VarType(docTypes) = vbString Then docTypes = Split(docTypes, ",")
    
    Dim ErrMsg As String
    ErrMsg = "ﾌｧｲﾙのﾀｲﾌﾟが異なります。" + vbNewLine + "(" + Join(docTypes, ",") + " のみです)"
    
    Dim actDoc As Document
    On Error Resume Next
        Set actDoc = CATIA.ActiveDocument
    On Error GoTo 0
    If actDoc Is Nothing Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    If UBound(filter(docTypes, typename(actDoc))) < 0 Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    CanExecute = True
End Function

こちらのKCLを導入して頂くと、もっとコードが短くなります。
非常に個人的なCATVBA用ﾗｲﾌﾞﾗﾘ - C#ATIA

サーフェスの重心をDrawのﾃｰﾌﾞﾙに書き込む

御相談頂いた、サーフェスの重心をDrawのテーブルに書き込むサンプルです。

Drawからスタートし、途中でPartに切り替えて何かを指定しなければならない
マクロの場合、SelectElement4を使用する必要が有ります。（他の手法は知りません）

'vba
'Drawからマクロをスタートし、Partのサーフェスを指定
'Drawにﾃｰﾌﾞﾙを新作し、重心位置を書き込む

Option Explicit

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'ｻｰﾌｪｽ選択
    Dim msg As String
    msg = "重心を求めるｻｰﾌｪｽを指定してください / ESCキー ｷｬﾝｾﾙ"
    
    Dim elm As SelectedElement
    Set elm = SelectElement4(msg, msg, Array("Face"))
    
    '重心
    Dim cog As Variant
    cog = GetCog(elm.Value, elm.Document)
    
    'ﾃｰﾌﾞﾙ作成
    Dim tb As DrawingTable
    Set tb = InitDrawTable
    
    'ﾃｰﾌﾞﾙに書き込み
    Call WriteTable(tb, elm.Value.DisplayName, Join(cog, ","))
    
    'fin
    MsgBox "Done"

End Sub

'ﾃｰﾌﾞﾙ書き込み
Private Sub WriteTable( _
    ByVal tb As DrawingTable, _
    ByVal faceName As String, _
    ByVal cog As String)
    
    Call tb.SetCellString(1, 1, faceName)
    Call tb.SetCellString(1, 2, cog)

End Sub

'重心
Private Function GetCog( _
    ByVal face As face, _
    ByVal doc As Document) _
    As Variant
    
    Dim spa As Object
    Set spa = doc.GetWorkbench("SPAWorkbench")
    
    Dim mes As Variant ' Measurable
    Set mes = spa.GetMeasurable(face)
    
    Dim cog(2) As Variant
    mes.GetCog cog
    
    GetCog = cog
    
End Function

'SelectElement4
Private Function SelectElement4( _
    ByVal msg1 As String, _
    ByVal msg2 As String, _
    ByVal filter As Variant) _
    As AnyObject
    
    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.selection
    Dim targetDoc As Variant 'Document 型指定Ng
    
    sel.Clear
    Select Case sel.SelectElement4(filter, msg1, msg2, _
                                   True, targetDoc)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    
    Dim tgtSel As selection
    Set tgtSel = targetDoc.selection
    Set SelectElement4 = tgtSel.Item2(1)
    
    sel.Clear
    tgtSel.Clear
End Function

'アクティブなビューにDrawﾃｰﾌﾞﾙの作成
Private Function InitDrawTable() _
    As DrawingTable
    
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    Dim vi As DrawingView
    Set vi = dwDoc.Sheets.ActiveSheet.views.ActiveView

    Set InitDrawTable = vi.Tables.Add( _
        -100#, _
        200#, _
        3, _
        2, _
        8#, _
        20#)
        
End Function
    
'ｴﾗｰ回避の為のﾄﾞｷｭﾒﾝﾄﾀｲﾌﾟﾁｪｯｸ
Private Function CanExecute( _
    ByVal docTypes As Variant) _
    As Boolean
    
    CanExecute = False
    
    If CATIA.Windows.Count < 1 Then
        MsgBox "ﾌｧｲﾙが開かれていません"
        Exit Function
    End If
    
    If VarType(docTypes) = vbString Then docTypes = Split(docTypes, ",")
    
    Dim ErrMsg As String
    ErrMsg = "ﾌｧｲﾙのﾀｲﾌﾟが異なります。" + vbNewLine + "(" + Join(docTypes, ",") + " のみです)"
    
    Dim actDoc As Document
    On Error Resume Next
        Set actDoc = CATIA.ActiveDocument
    On Error GoTo 0
    If actDoc Is Nothing Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    If UBound(filter(docTypes, typename(actDoc))) < 0 Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    CanExecute = True
End Function

正直な所、使いにくいような気もしていますが、
コード的なXXX　を質問されるより、全体としてどんな処理をしたいのか？
まで伝えて頂いた方が、手間が少ない上、コードもすっきりします。

カレントビューの角度や生成スタイルの取得

「ビューの角度や生成スタイルの変更」について、御質問頂きました。

変更についてのサンプルコードは書きにくいため、カレントビュー情報を
幾つか表示するサンプルコードを作ってみました。

Sub CATMain()
    
    Dim msg As String
    Dim pi As Double: pi = 4 * Atn(1)
    
    'ﾄﾞｷｭﾒﾝﾄ
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    'ｶﾚﾝﾄﾋﾞｭｰ : 名前の変更はnameﾌﾟﾛﾊﾟﾃｨに代入
    Dim actVi As DrawingView
    Set actVi = dwDoc.Sheets.ActiveSheet.views.ActiveView
    msg = "ﾋﾞｭｰ名 : " & actVi.Name
    
    '角度 : 変更はangleﾌﾟﾛﾊﾟﾃｨに代入(単位ﾗｼﾞｱﾝで!)
    msg = msg & vbCrLf & _
        "角度 : " & Round(actVi.angle * (180 / pi), 3) & "deg"
    
    'ｽｹｰﾙ : 変更はscaleﾌﾟﾛﾊﾟﾃｨに代入
    msg = msg & vbCrLf & _
        "ｽｹｰﾙ : " & actVi.Scale
    
    'ｽﾀｲﾙ : 変更は、恐らくSetGPSNameﾒｿｯﾄﾞ
    Dim behv As DrawingViewGenerativeBehavior
    Set behv = actVi.GenerativeBehavior
    msg = msg & vbCrLf & _
        "ｽﾀｲﾙ(のﾌｧｲﾙ名) : " & behv.GetGPSName
    
    '参照している3Dﾄﾞｷｭﾒﾝﾄ : 変更は、下記にｻﾝﾌﾟﾙｺｰﾄﾞ有り
    'http://kantoku.hatenablog.com/entry/2018/12/19/183339
    msg = msg & vbCrLf & _
        "参照ﾄﾞｷｭﾒﾝﾄ : " & behv.Document.Parent.FullName
    
    
    MsgBox msg, , "** ｶﾚﾝﾄﾋﾞｭｰ情報 **"
    
End Sub

※例外処理を省いている為、3Dとリンクしていないビューで実行すると
エラーになると思います。
他にも、断面や詳細図のビューの場合、どのビューを元に作成されたか？
の取得も可能です。

実行するとこんな感じです。

念のためですが、ビュー名の変更はNameプロパティに代入で良いのですが

IDやSuffixが関係してくると、もうちょっとややこしいです。

自分の場合も、特定の客先向けで
・PartとDrawﾌｧｲﾙ名が一致しているか？
・ファイル名がルールに基づいた名称となっているか？
・生成スタイルが適切か？
等の細々したチェック(箇条書き出来る様な内容のもの)は、マクロで行っています。
（面倒なので）

カレントビュー内のテキスト・寸法全てを削除する

「Drawのカレントビュー内のテキストと寸法を削除したいが、
　最初の1個しか削除されない」
とのご相談を頂きました。

とりあえず、検索の現行選択でテキストと寸法を選択するマクロの記録をし、
不要そうな部分を削除しつつ、変数名を修正したものがこちらです。

Sub CATMain()
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    Dim sel As selection
    Set sel = dwDoc.selection
    
    sel.Search "(CATDrwSearch.DrwDimension + CATDrwSearch.DrwText),sel"
End Sub

実際に欲しいのは事前選択ではなくカレントビューの為、カレントビューを
事前に選択させつつ、高輝度表示もOffにします。

Sub CATMain()
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    Dim sel As selection
    Set sel = dwDoc.selection
    
    Dim actVi As DrawingView
    Set actVi = dwDoc.Sheets.ActiveSheet.views.ActiveView
    
    CATIA.HSOSynchronized = False
    
    With sel
        .Clear
        .Add actVi
        .Search "(CATDrwSearch.DrwDimension + CATDrwSearch.DrwText),sel"
    End With

    CATIA.HSOSynchronized = True
End Sub

恐らく上手く削除出来ない原因は、ここからループ等で一個づつ削除しているのでは
無いのかな？　と思います。
僕は、Drawでの要素の削除はSelectionで選択しDelete（又はCut）するしか
方法がわかりません。（GSOはもっと高速な削除方法が有ります）

確認メッセージをつけた上、削除するように変更するとこんな感じです。

Sub CATMain()
    Dim dwDoc As DrawingDocument
    Set dwDoc = CATIA.ActiveDocument
    
    Dim sel As selection
    Set sel = dwDoc.selection
    
    Dim actVi As DrawingView
    Set actVi = dwDoc.Sheets.ActiveSheet.views.ActiveView
    
    CATIA.HSOSynchronized = False
    
    '検索
    With sel
        .Clear
        .Add actVi
        .Search "(CATDrwSearch.DrwDimension + CATDrwSearch.DrwText),sel"
    End With
    
    Dim delCount As Long
    delCount = sel.Count2
    
    Dim msg As String
    
    '削除要素無し
    If delCount < 1 Then
        msg = "ビュー[" & actVi.Name & "]内に削除要素が有りません!"
        MsgBox msg, vbInformation
        GoTo fin
    End If
    
    '確認
    msg = "ビュー[" & actVi.Name & "]内の" & vbCrLf & _
        "ﾃｷｽﾄ・寸法 " & delCount & "個 全てを削除します" & vbCrLf & _
        "宜しいですか?"
    
    If MsgBox(msg, vbYesNo + vbQuestion) = vbNo Then
        GoTo fin
    End If
    
    '削除
     sel.Delete '←ここ　検索で選択したもの全てを削除
fin:
    CATIA.HSOSynchronized = True
End Sub

どうでしょうか？

指定した要素を新たなPartにｺﾋﾟﾍﾟして保存

久々のCATIAのマクロです。

アクティブなPartファイル上で指定した要素を、新たなPartに ”結果として” で
コピペし保存します。

'vba NewPart_CopyAndPasteResult  using-'KCL0.0.13'  by Kantoku
'指定した要素を新たなPartファイルに"結果として"でコピペする

Option Explicit

Private Const FOOTER = "_copy"

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    '元ﾊﾟｽ
    Dim docPath As String
    docPath = CATIA.ActiveDocument.FullName
    
    'ｺﾋﾟｰ
    Dim msg As String
    msg = "新たなPartにコピーする要素を選択してください / ESC-ｷｬﾝｾﾙ"
    
    Call SelectItemsCopy(msg, Array("AnyObject"))
    
    'ﾍﾟｰｽﾄ
    Dim docs As Documents
    Set docs = CATIA.Documents
    
    Dim newDoc As PartDocument
    Set newDoc = docs.Add("Part")
    
    Call SelectItems(newDoc)
    CATIA.RefreshDisplay = True
    
    '保存
    Dim newPath As String
    newPath = GetNewPath(docPath)
    
    Call newDoc.SaveAs(newPath)
    
    MsgBox "done"
    
End Sub

'ﾍﾟｰｽﾄﾊﾟｽ
Private Function GetNewPath( _
    ByVal path As String) As String
    
    Dim tmp As Variant
    tmp = KCL.SplitPathName(path)
    tmp(1) = tmp(1) & FOOTER
    
    GetNewPath = KCL.GetNewName(KCL.JoinPathName(tmp))
End Function

'ﾍﾟｰｽﾄ
Private Sub SelectItems( _
    ByVal newDoc As PartDocument)
    
    newDoc.Activate
    
    Dim sel As Selection
    Set sel = newDoc.Selection
    
    CATIA.HSOSynchronized = False
    
    With sel
        .Clear
        .Add newDoc.part
        .PasteSpecial "CATPrtResultWithOutLink"
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
End Sub

'ｺﾋﾟｰ
Private Sub SelectItemsCopy( _
    ByVal msg As String, _
    ByVal filter As Variant)
    
    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.Selection
    
    sel.Clear
    Select Case sel.SelectElement3(filter, _
                                   msg, _
                                   True, _
                                   CATMultiSelTriggWhenUserValidatesSelection, _
                                   False)
        Case "Cancel", "Undo", "Redo"
            End
    End Select
    
    If sel.count < 1 Then End
    
    sel.Copy
    sel.Clear
End Sub

特に何て事の無い内容で、単に加工のためのPowerMill用にエクスポートする為です。
(ある意味、履歴無しのPartファイルを作っているような感じです)

元のPartファイルと同一フォルダに、元のファイル名 + "_copy" の新たなファイルを
作成します。

ディテールシートの未使用のビューを削除

図面を作成する際、面倒なので新規のDrawファイルからでは無くて
他のファイルを流用して作りますよね？（・・・違うかな）
最大の理由はカタログから呼び出した際、分離してディテールシートに
残しているのですが、再度同じものをカタログから呼び出すのが面倒だからです。

差し替えが上手くいけば問題無いですし、UUID違いもこちらのマクロで
それなりの事が出来るようになりました。
異なるUUIDのDraw参照元ファイルを差し替える3 - C#ATIA
（知り合いの方から、新規に作成した方が早いんじゃない？　と
アドバイスを頂きました。　・・・確かにそうです。）

ビューの原点も（ｲﾛｲﾛ問題は有りますが）こちらで変更できるようになりました。
Drawﾋﾞｭｰの原点を変更する1 - C#ATIA

こんな感じで流用していると、つまらない意地と言いますか、見栄と言いますか
ディテールシートに未使用のビューが幾つか残ったりするのですが、嫌なんです。
使用している物を削除しようとすると警告してくれるので、手動でも出来ない
ことは無いのですが、、、面倒なんです。

そこでDrawファイル内で、2Dコンポーネントとして使用されていない
ディテールシートのビューを削除するマクロを作成しました。

'vba DetailSheetCleaner_ver0.0.1  using-'KCL0.0.13'  by Kantoku
Option Explicit

Sub CATMain()
    
    Dim msg As String
    
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute(Array("DrawingDocument")) Then Exit Sub
    
    Dim doc As DrawingDocument
    Set doc = CATIA.ActiveDocument
    
    'ﾃﾞｨﾃｰﾙｼｰﾄ
    Dim dets As Collection
    Set dets = GetDetailSheet(doc)
    If dets.Count < 1 Then
        MsgBox "ﾃﾞｨﾃｰﾙｼｰﾄが有りません!"
        Exit Sub
    End If
    
    '全ｺﾝﾎﾟｰﾈﾝﾄ 空の可能性も有り
    Dim cmps As Collection
    Set cmps = GetComps(doc.Sheets)
    
    'ﾃﾞｨﾃｰﾙｼｰﾄﾋﾞｭｰ辞書
    Dim compDic As Object
    Set compDic = InitDetailDic(dets)
    
    '未使用ﾃﾞｨﾃｰﾙｼｰﾄﾋﾞｭｰ
    Dim UnuseComps As Collection
    Set UnuseComps = GetUnuseCompsList(compDic, cmps)
    If UnuseComps.Count < 1 Then
        MsgBox "削除対象のﾋﾞｭｰが有りません!"
        Exit Sub
    End If
    
    '確認
    msg = UnuseComps.Count & _
        "個の未使用ﾃﾞｨﾃｰﾙｼｰﾄのﾋﾞｭｰが有ります。" & vbCrLf & _
        "全て削除しますか?"

    If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then
        Exit Sub
    End If
    
    '削除
    Call RemoveComps(UnuseComps)
    
    MsgBox "Done"
End Sub

Private Sub RemoveComps( _
    ByVal lst As Collection)
    
    Dim sel As selection
    Set sel = CATIA.ActiveDocument.selection
    
    CATIA.HSOSynchronized = False
    
    Dim vi As DrawingView
    
    With sel
        .Clear
        For Each vi In lst
            .Add vi
        Next
        .Delete
    End With
    
    CATIA.HSOSynchronized = True
    
End Sub

Private Function GetComps( _
    ByVal shts As DrawingSheets) As Collection
    
    Dim cmps As Collection
    Set cmps = New Collection
    
    Dim st As DrawingSheet
    Dim vi As DrawingView
    Dim i As Long
    For Each st In shts
        For Each vi In st.views
            For i = 1 To vi.Components.Count
                cmps.Add vi.Components.Item(i)
            Next
        Next
    Next
    
    Set GetComps = cmps
    
End Function

Private Function GetUnuseCompsList( _
    ByVal compDic As Object, ByVal cmps As Collection) _
    As Collection
        
    Dim cmp As DrawingComponent
    Dim key As String
    For Each cmp In cmps
        key = GetKeyString(cmp.CompRef)
        If compDic.Exists(key) Then
            compDic(key) = Array(True, compDic(key)(1))
        End If
    Next
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim ary As Variant
    For Each ary In compDic.Items
        If ary(0) = False Then
            lst.Add ary(1)
        End If
    Next
    
    Set GetUnuseCompsList = lst
    
End Function

Private Function GetKeyString( _
    ByVal vi As DrawingView) As String
    
    GetKeyString = vi.Parent.Parent.Name & "@" & _
        KCL.GetInternalName(vi)
End Function

Private Function InitDetailDic( _
    ByVal dets As Collection) As Object
    
    Dim dic As Object
    Set dic = KCL.InitDic()
    
    Dim st As DrawingSheet
    Dim i As Long
    Dim vi As DrawingView
    For Each st In dets
        For i = 3 To st.views.Count
            Set vi = st.views.Item(i)
            dic.Add GetKeyString(vi), Array(False, vi)
        Next
    Next
    
    Set InitDetailDic = dic
    
End Function

Private Function GetDetailSheet( _
    ByVal doc As DrawingDocument) As Collection
    
    Dim dets As Collection
    Set dets = New Collection
    
    Dim st As DrawingSheet
    For Each st In doc.Sheets
        If st.IsDetail Then
            dets.Add st
        End If
    Next
    
    Set GetDetailSheet = dets
    
End Function

言葉だけではわかりにくいので、こんな感じです。

ディテールシートに「maru」と「shikaku」を作成します。

えぇネーミングセンス0です。

シートで「maru」だけインスタンスを作成して貼り付けます。

この状態でマクロを実行すると

「shikaku」は未使用なので削除します。