CATIA V5 未使用のディテール削除

内容

DRAWINGファイルの中にある未使用のディテールを削除するマクロ

使用方法

ディテールを削除したい.CATDrawingファイルを開く。
CATIAからVisual Basic エディターを開く。
→　「ツール」　⇒　「マクロ」　⇒　「Visual Basic エディター」
コードウィンドウに下記のコードをコピペし実行する。

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

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

.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)

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

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

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)

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

Set GetDetailSheet = dets

End Function