読者です 読者をやめる 読者になる 読者になる

C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA

2Dコンポーネントを展開する

こちらの続きです。
指定した2D要素を、指定した原点位置でコピペする - C#ATIA


予告していた、2Dコンポーネント(2D構成要素)を展開するマクロです。

アクティブなDrawシート全てのビュー内(メイン・背景・ロック・非表示)にある
2Dコンポーネントが対象です。

'vba sample_Comp2DExplode ver0.0.3
'using-'KCL0.09'
'アゥティブなシートのメインと背景以外のビューにある2Dコンポーネントを全て展開

Option Explicit

Sub CATMain()
    'ドキュメントのチェック
    If Not KCL.CanExecute("DrawingDocument") Then Exit Sub

    'コンポーネント2Dの存在するビュー取得
    Dim ViewLst As Collection: Set ViewLst = GetExistComp2DView()
    If ViewLst.Count < 1 Then
        MsgBox "アクティブなシート内のアンロックされたビュー内には、" & vbNewLine & _
               "コンポーネント2Dが存在しませんでした", vbInformation
        Exit Sub
    End If
    
    'コンポーネント2D取得
    Dim CompLst As Collection: Set CompLst = GetComp2DList(ViewLst)
    
    'ユーザー選択
    Dim Msg$: Msg = "アクティブなシートには" & _
                    CreateMsg(ViewLst, CompLst) & vbNewLine & _
                    "のコンポーネント2Dが存在します。 全て展開しますか?"
    If MsgBox(Msg, vbOKCancel + vbInformation) = vbCancel Then Exit Sub
    
    '展開
    Call ExecuteExplode(CompLst)
    
    '終了
    MsgBox "終了"
End Sub

'展開
Private Sub ExecuteExplode(ByVal CompLst As Collection)
    Dim Lst As Collection
    Dim Cmp As DrawingComponent
    Dim Sel As Selection: Set Sel = CATIA.ActiveDocument.Selection
    
    CATIA.HSOSynchronized = False
        Sel.Clear
        For Each Lst In CompLst
            For Each Cmp In Lst
                Cmp.Explode
                Sel.Add Cmp
            Next
        Next
        Sel.Delete
    CATIA.HSOSynchronized = True
End Sub

'メッセージ作成
Private Function CreateMsg(ByVal ViewLst As Collection, _
                            ByVal CompLst As Collection) As String
    Dim Ary(): ReDim Ary(ViewLst.Count)
    Dim i&
    For i = 1 To ViewLst.Count
        Ary(i) = "ビュー '" & ViewLst(i).Name & "' - " & _
                    CStr(CompLst(i).Count) & "個"
    Next
    CreateMsg = Join(Ary, vbNewLine)
End Function

'コンポーネント2D取得
Private Function GetComp2DList(ByVal ViewLst As Collection) As Collection
    Set GetComp2DList = Nothing
    
    Dim Vw As DrawingView
    Dim Lst As Collection: Set Lst = New Collection
    For Each Vw In ViewLst
        Lst.Add DeepCopyCatCollection(Vw.Components, "DrawingComponents")
    Next
    Set GetComp2DList = Lst
End Function

'コンポーネント2Dの存在するビュー取得  メイン・背景・ロック・非表示除外
Private Function GetExistComp2DView() As Collection
    Set GetExistComp2DView = Nothing
    
    Dim Vws As DrawingViews
    Set Vws = CATIA.ActiveDocument.Sheets.ActiveSheet.Views
    If Vws.Count < 3 Then Exit Function
    
    Dim ViewLst As Collection
    Set ViewLst = DeepCopyCatCollection(Vws, "DrawingViews")
    Call ViewLst.Remove(1) 'メイン削除
    Call ViewLst.Remove(1) '背景削除
    
    
    Dim Vw As DrawingView
    Dim Lst As Collection: Set Lst = New Collection
    For Each Vw In ViewLst
        If Vw.LockStatus = False And IsShow(Vw) And _
                                Vw.Components.Count > 0 Then
            Lst.Add Vw
        End If
    Next
    Set GetExistComp2DView = Lst
End Function

'表示?
Private Function IsShow(ByVal Oj As AnyObject) As Boolean
    Dim Sel As Selection: Set Sel = CATIA.ActiveDocument.Selection
    Dim Vis As VisPropertySet:
    Set Vis = Sel.VisProperties
    Dim ShowState As CatVisPropertyShow
    
    CATIA.HSOSynchronized = False
        Sel.Clear
        Sel.Add Oj
        Call Vis.GetShow(ShowState)
        Sel.Clear
    CATIA.HSOSynchronized = True
    
    IsShow = IIf(ShowState = catVisPropertyDefined, True, False)
End Function

'クローン
Private Function DeepCopyCatCollection(ByVal CatCol As AnyObject, _
                                        ByVal OjType$) As Collection
    Set DeepCopyCatCollection = Nothing
    
    Dim Col As Variant
    Select Case OjType '面倒・・・
        Case "DrawingViews"
            Dim Vws As DrawingViews: Set Vws = CatCol
            Set Col = Vws
            
        Case "DrawingComponents"
            Dim Cmps As DrawingComponents: Set Cmps = CatCol
            Set Col = Cmps
            
        Case Else
            Set Col = CatCol
    End Select
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim v
    For Each v In Col
        Lst.Add v
    Next
    Set DeepCopyCatCollection = Lst
End Function

これぐらいなら、それ程苦労せずに作成出来るのですが。