C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA(最近はPMillマクロとFusion360APIが多い)

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

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

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

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とリンクしていないビューで実行すると
エラーになると思います。
他にも、断面や詳細図のビューの場合、どのビューを元に作成されたか?
の取得も可能です。

実行するとこんな感じです。
f:id:kandennti:20190522190026p:plain

念のためですが、ビュー名の変更はNameプロパティに代入で良いのですが
f:id:kandennti:20190522190117p:plain
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」を作成します。
f:id:kandennti:20190410172837p:plain
えぇネーミングセンス0です。

シートで「maru」だけインスタンスを作成して貼り付けます。
f:id:kandennti:20190410172850p:plain

この状態でマクロを実行すると
f:id:kandennti:20190410172901p:plain
「shikaku」は未使用なので削除します。

指定ビュー内の2Dコンポーネントを削除する

「ビュー内の2Dコンポーネントを削除する方法」について御質問頂きました。

2Dコンポーネントについては、DrawingView内のComponentsプロパティの
コレクションが所有した状態になっています。

'vba 指定ビュー内の2Dコンポーネントを削除する
Option Explicit

Sub CATMain()

    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    'ビュー選択
    Dim msg As String
    msg = "2Dコンポーネントを削除するビューを選択してください / ESC-キャンセル"
    
    Dim sel 'As selection
    Set sel = dDoc.selection
    
    Dim status As String
    sel.Clear
    status = sel.SelectElement2(Array("DrawingView"), msg, False)
    If Not status = "Normal" Then Exit Sub
    
    Dim vi As DrawingView
    Set vi = sel.Item2(1).Value
    sel.Clear

    '2Dコンポーネント数確認
    If vi.Components.Count < 1 Then
        msg = vi.Name & " には、2Dコンポーネントが有りません"
        MsgBox msg
        Exit Sub
    End If
    
    '確認
    msg = vi.Name & " には、" & vi.Components.Count & _
        "個の2Dコンポーネントが有ります。" & vbCrLf & _
        "全て削除しますか?"
    
    If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then
        Exit Sub
    End If
    
    '2Dコンポーネント削除
    
    CATIA.HSOSynchronized = False
    
    Dim comp As DrawingComponent
    For Each comp In vi.Components
        sel.Add comp
    Next
    sel.Delete
    
    CATIA.HSOSynchronized = True
    
    '終わり
    MsgBox "done"
End Sub

同様に
テキスト : Texts
寸法 : Dimensions
等も検索を使用せずに同様の処理が可能です。

Drawビューの原点を変更する1

3Dを元に2Dを作成する際、単に平面を指定すると3Dの原点が
2Dの各ビューの原点になりますが、任意の座標系を2Dの原点としたい場合
座標系を選択した上で平面を指定すればOKですよね?
(言葉では表現しにくいですね)

こんな3Dデータだとします。
f:id:kandennti:20190305120004p:plain
オレンジ色が製品原点で、黄色が部品原点だとします。
実はオレンジ色は絶対座標系です。

2Dを作成する際、何も考えずに平面だけを指定して作業を始めました。
f:id:kandennti:20190305120014p:plain
すいません、適当で・・・。この場合は、最初のオレンジ色(絶対座標系)
の位置が各ビューの原点になっています
f:id:kandennti:20190305120024p:plain
ところが、「お前、何やっているんだ?部品原点を基準に寸法入れるに
決まっているだろ!」と言う事になった場合、どうするのでしょうか?

こちらに「投影平面を修正」コマンドがあるのですが、これはビューの
向きを修正してくれるのですが、原点は変更してくれないですよね?
f:id:kandennti:20190305120033p:plain
探しても探しても原点を修正するコマンドが見つからず、サポートさんに
問い合わせても機能が無いと判りました。(その節はお世話になりました)

代案としては、部品原点の位置に点や線を何らかの方法で作成し、
そこを元に寸法を入れ直し・・・となるのかな?と感じてます。
手間ですね。苦労が水の泡です。

少し前に気になった、こちらのメソッドを利用するとビューの原点位置を
変更出来るのではないかな? と感じていました。
r1 DrawingViewGenerativeBehavior (Object)
試した所、原点の変更可能がでした。

これを利用して、2Dの原点修正マクロを作成しました。

'vba Draw_ChangeOrigin ver0.0.1  by Kantoku
'using-'KCL0.0.13'

'ビューの原点を変更します

'指定出来るビューは、基準ビューとアイソメのみでロックされていないもの。
'影響を受けるビューは強制的にアンロックします。
'変更後に指定出来る座標系は、リンク元のファイルに限定しています。
'3Dから生成したライン・テキスト等は移動されませんが
'2Dコンポーネント・2D上で描いたライン等が移動します。

'アイソメ図は関連した図として扱わない
'分離図は対象外
'CGRのみのビューはエラーになる可能性あり
'図の生成モードがCGRの場合、エラーの可能性あり

Option Explicit

Sub CATMain()

    Dim msg As String

    'ドキュメントのチェック
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'DrawDoc
    Dim actDoc As DrawingDocument
    Set actDoc = CATIA.ActiveDocument
    
    '保存確認
    If actDoc.Saved = False Then
        msg = "ファイルが変更されています!" & vbCrLf & _
            "一度保存後にマクロの実行をお勧めしますが、" & vbCrLf & _
            "このままマクロを実行しますか?"
        If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    
    'ビュー選択
    msg = "投影原点を変更するビューを選択 / ESC-キャンセル" & vbCrLf & _
        "(リンクを持ったロックされていない基準ビュ-のみ)"
    
    Dim vi As DrawingView
    Set vi = SelectView(msg)
    If vi Is Nothing Then Exit Sub

    
    '参照Doc-分離エラ-
    Dim refDoc As Document
    Set refDoc = GetDocument( _
        vi.GenerativeLinks.FirstLink())
    
    'assy対策
    Dim refDocs As Collection
    Set refDocs = New Collection
    
    Set refDocs = GetChildDocList(refDoc, refDocs)
    
    '参照Docが開かれているか?
    If Not IsOpenDoc(refDoc) Then
        msg = refDoc.Name & vbCrLf & _
            "が開かれていません!" & vbCrLf & _
            "開いてから再度実行してください"
        MsgBox msg, vbExclamation
        Exit Sub
    End If
    
    '選択ビュー座標系取得
    Dim BeforeAx As AxisSystem
    Set BeforeAx = GetRefAxis(vi, refDoc.Product)
    
    '選択ビューを参照しているビュー取得
    Dim vis As Collection
    Set vis = GetReferringViewList(vi)
    
    '座標系選択
    msg = "新しい座標系を" & vbCrLf & _
        refDoc.Name & vbCrLf & _
        "から選択してください" & vbCrLf & _
        "(ESC-キャンセル)"
    MsgBox msg
    
    Dim AfterAx As AxisSystem
    Set AfterAx = SelectAxis(msg, BeforeAx, refDocs)
    If AfterAx Is Nothing Then Exit Sub
    
    '確認
    msg = CreateMsg(vi, vis, BeforeAx, AfterAx)
    If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then
        actDoc.selection.Clear
        Exit Sub
    End If
    actDoc.selection.Clear
    
    'Behavior取得
    Dim behavs As Collection
    Set behavs = GetGenBehaviorList(vis)
    
    '変更
    CATIA.RefreshDisplay = False
    Call ChangeAxis(behavs, AfterAx, refDoc.Product)
    CATIA.RefreshDisplay = True
    
    MsgBox "done"
    
End Sub

'Assy時の子Docの取得
Private Function GetChildDocList( _
    ByVal doc As Document, _
    ByVal lst As Collection) _
    As Collection
    
    If Not typename(doc) = "ProductDocument" Then
        lst.Add doc
        Set GetChildDocList = lst
    End If
    
    Dim pros As Products
    Set pros = doc.Product.Products
    
    Dim pro As Product
    Dim childDoc As Document
    For Each pro In pros
        Set childDoc = pro.ReferenceProduct.Parent 'doc
        'cgrはここでProductDocumentを返している
        If childDoc Is Nothing Then GoTo continue
        
        If typename(childDoc) = "ProductDocument" Then
            If Not IsEqDoc(childDoc, doc) Then
                 Set lst = GetChildDocList(childDoc, lst)
            End If
        Else
            lst.Add childDoc
        End If
continue:
    Next
    
    Set GetChildDocList = lst
    
End Function

'パラメータで戻り値をCATSafeArrayVariantで受け取るタイプに効果絶大
Private Function AsDisp( _
    o As INFITF.CATBaseDispatch) _
    As INFITF.CATBaseDispatch
    
    Set AsDisp = o
    
End Function

'座標系の一致
'Docが一致しジオメトリ的に一致していれば、一致と判断
Private Function IsEqAxis( _
    ByVal ax1 As AxisSystem, _
    ByVal ax2 As AxisSystem) _
    As Boolean
    
    IsEqAxis = False
    
    If ax1 Is Nothing And ax2 Is Nothing Then
        IsEqAxis = True
        Exit Function
    End If
    
    If ax1 Is Nothing Or ax2 Is Nothing Then
        Exit Function
    End If
    
    Dim doc1 As Document
    Set doc1 = GetDocument(ax1)
    
    Dim doc2 As Document
    Set doc2 = GetDocument(ax2)
    
    If Not IsEqDoc(doc1, doc2) Then Exit Function
    
    Dim ori1(2) As Variant
    AsDisp(ax1).GetOrigin ori1
    
    Dim ori2(2) As Variant
    AsDisp(ax2).GetOrigin ori2
    
    If Not KCL.IsAryEqual(ori1, ori2) Then Exit Function
    
    Dim vecX1(2) As Variant
    Dim vecY1(2) As Variant
    AsDisp(ax1).GetVectors vecX1, vecY1
    
    Dim vecX2(2) As Variant
    Dim vecY2(2) As Variant
    AsDisp(ax2).GetVectors vecX2, vecY2
    
    If Not KCL.IsAryEqual(vecX1, vecX2) Then Exit Function
    If Not KCL.IsAryEqual(vecY1, vecY2) Then Exit Function
    
    IsEqAxis = True
    
End Function

'ドキュメントの一致
'doc1 is doc2 では上手く行かない時がある
Private Function IsEqDoc( _
    ByVal doc1 As Document, _
    ByVal doc2 As Document) _
    As Boolean
        
    IsEqDoc = IIf(doc1.FullName = doc2.FullName, _
                  True, _
                  False)
    
End Function

'ドキュメントが開かれているか? 正しくは可視か?
Private Function IsOpenDoc( _
    ByVal doc As Document) _
    As Boolean
    
    IsOpenDoc = True
    
    Dim ws As Windows
    Set ws = CATIA.Windows
    
    Dim w As Window
    For Each w In ws
        If IsEqDoc(w.Parent, doc) Then Exit Function
    Next
    
    IsOpenDoc = False
    
End Function

'座標系変更
Private Sub ChangeAxis( _
    ByVal lst As Collection, _
    ByVal ax As AxisSystem, _
    ByVal pro As Product)
    
    CATIA.RefreshDisplay = False
    
    Dim br As DrawingViewGenerativeBehavior
    
    For Each br In lst
        br.SetAxisSysteme pro, ax
        br.ForceUpdate
    Next
    
    CATIA.RefreshDisplay = True
    
End Sub

'GenerativeBehavior取得 ロックも解除
Private Function GetGenBehaviorList( _
    ByVal vis As Collection) As Collection
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim vi As DrawingView
    For Each vi In vis
        vi.LockStatus = False
        lst.Add vi.GenerativeBehavior
    Next
    
    Set GetGenBehaviorList = lst
    
End Function

'確認メッセージ作成
Private Function CreateMsg( _
    ByVal vi As DrawingView, _
    ByVal vis As Collection, _
    ByVal BeforeAx As AxisSystem, _
    ByVal AfterAx As AxisSystem)
    
    Dim msg As String
    msg = vi.Name & "の投影基準を" & vbCrLf
    
    If Not BeforeAx Is Nothing Then
        msg = msg & "[" & BeforeAx.Name & "]から"
    End If
    msg = msg & "[" & AfterAx.Name & "]" & vbCrLf & _
        "に変更します。" & vbCrLf
        
    If vis.Count > 0 Then
        msg = msg & "又、以下のビューが影響を受けます" & vbCrLf & _
            ExtractViewsName(vis) & _
            "(☆印はロックを強制解除します)" & vbCrLf
    End If
    
    CreateMsg = msg & "変更し強制更新を実行しますか?"
    
End Function

'リスト内ビュー名取得 - ロックされているものは☆付き
'ついでに選択
Private Function ExtractViewsName( _
    ByVal lst As Collection)
    
    Dim sel As selection
    Set sel = CATIA.ActiveDocument.selection
    
    Dim msg As String
    Dim vi As DrawingView
    
    CATIA.HSOSynchronized = False
    sel.Clear
    
    For Each vi In lst
        If vi.LockStatus Then
            msg = msg & "☆"
        Else
            msg = msg & "・"
        End If
        sel.Add vi
        msg = msg & vi.Name & vbCrLf
    Next
    
    CATIA.HSOSynchronized = True
    
    ExtractViewsName = msg
    
End Function

'新たな座標系選択
Private Function SelectAxis( _
    ByVal msg As String, _
    ByRef refAx As AxisSystem, _
    ByRef lst As Collection) _
    As AxisSystem
    
    Set SelectAxis = Nothing
    
    Dim ax As AxisSystem
    Dim selDoc As Document
    
    Do
        Set ax = SelectItem4(msg, msg, Array("AxisSystem"))
        If ax Is Nothing Then Exit Function
        
        Set selDoc = GetDocument(ax)
        
        Select Case True
            Case Not IsExistsList(lst, selDoc)
                MsgBox msg, vbExclamation
            Case IsEqAxis(ax, refAx)
                MsgBox "変更前と同じ座標系です", vbExclamation
            Case Else
                Set SelectAxis = ax
                Exit Function
        End Select
continue:
    Loop
    
End Function

'指定ビューに関連しているビューの取得
Private Function GetReferringViewList( _
    ByVal refVi As DrawingView) _
    As Collection
    
    Dim vis As DrawingViews
    Set vis = refVi.Parent
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim lstCnt As Long
    lst.Add refVi
    
    Dim vi As DrawingView
    Do
        lstCnt = lst.Count
        For Each vi In vis
        
            '既にリストに登録
            If IsExistsList(lst, vi) Then GoTo continue
            
            '分離
            If IsIsolate(vi) Then GoTo continue
            
            '拡大図
            If IsExistsList(lst, vi.GenerativeBehavior.ParentView) Then
                    lst.Add vi
                    GoTo continue
            End If
            
            '正面図等
            If Not vi.ReferenceView Is Nothing And _
                IsExistsList(lst, vi.ReferenceView) Then
                    lst.Add vi
                    GoTo continue
            End If
continue:
        Next
    Loop Until lstCnt = lst.Count
    
    Set GetReferringViewList = lst

End Function

'リスト内に同じものがあるか?
Private Function IsExistsList( _
    ByVal lst As Collection, _
    ByVal itm As AnyObject) _
    As Boolean
    
    IsExistsList = True
    
    Dim oj As AnyObject
    
    'docだけはfullname
    If InStr(1, typename(itm), "Document") > 0 Then
        For Each oj In lst
            If IsEqDoc(oj, itm) Then Exit Function
        Next
    Else
        For Each oj In lst
            If oj Is itm Then Exit Function
        Next
    End If
    IsExistsList = False
    
End Function

'分離?
Private Function IsIsolate( _
    ByVal vi As DrawingView) _
    As Boolean
    
    On Error Resume Next
    
    Dim dmy As AnyObject
    Set dmy = vi.GenerativeBehavior.Document
    
    On Error GoTo 0
    Err.Number = 0
    
    IsIsolate = IIf(dmy Is Nothing, True, False)
    
End Function

'ビューの持つ座標系取得 - nothingを返す事も有り
Private Function GetRefAxis( _
    ByVal vi As DrawingView, _
    ByVal pro As Product) _
    As AxisSystem
    
    Dim br As DrawingViewGenerativeBehavior
    Set br = vi.GenerativeBehavior
    
    On Error Resume Next
    
    Dim ax As AxisSystem
    Call br.GetAxisSysteme(pro, ax)
    
    On Error GoTo 0
    Err.Number = 0
    
    Set GetRefAxis = ax
    
End Function

'ビュー選択
Private Function SelectView( _
    ByVal msg As String) _
    As DrawingView
    
    Set SelectView = Nothing
    
    Do
        Dim vi As DrawingView
        Set vi = KCL.SelectItem(msg, "DrawingView")
        If vi Is Nothing Then Exit Function
                
        'ロック
        If vi.LockStatus Then
            MsgBox "ロックされています", vbExclamation
            GoTo continue
        End If
        
        Select Case True
        
            '分離
'            Case IsIsolate(vi)
'                MsgBox "分断されたビューは無効です", vbExclamation
            
            '拡大図
            Case Not (vi.GenerativeBehavior.ParentView Is Nothing)
                MsgBox "基準ビューのみです", vbExclamation
            
            '参照有り
            Case Not (vi.ReferenceView Is Nothing)
                MsgBox "基準ビューのみです", vbExclamation
                
            'ok
            Case Else
                Set SelectView = vi
                Exit Function
        End Select
continue:
    Loop

End Function

'指定objからドキュメントを取得
Private Function GetDocument( _
    ByVal oj As AnyObject) _
    As Document
    
    On Error Resume Next
        Set GetDocument = oj.GetItem("ModelElement").Document
    On Error GoTo 0
    If GetDocument Is Nothing Then
        'Topological,Geometry的なもの(CATSelectionFilter)はこちらで処理
        Set GetDocument = GetParent_Of_Document(oj)
    End If
    
End Function

'指定objからtParentでドキュメントを取得
Private Function GetParent_Of_Document( _
    ByVal oj As AnyObject) _
    As AnyObject

    Set GetParent_Of_Document = Nothing
    
    If typename(oj) = typename(oj.Parent) Then
        Exit Function
    End If
    
    If InStr(1, typename(oj), "Document") > 0 Then
        Set GetParent_Of_Document = oj
    Else
        Set GetParent_Of_Document = _
            GetParent_Of_Document(oj.Parent)
    End If
End Function

'SelectElement4
'pram:filter-AryVariant(string)
Private Function SelectItem4( _
    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 SelectItem4 = tgtSel.Item2(1).Value
    
    sel.Clear
    tgtSel.Clear
End Function

破壊力が抜群過ぎて注意すべき点が多数有ります。
又、(コード的に)本来チェックすべき事があるはずだろうと
思うのですが、設定が多彩過ぎて全てのパターンをテスト出来ずに
いるのも本音です。(特にCGRが含まれた場合等)

注意すべき点等は後日に記載します。
Blogでの長いコードの記載に限界を感じています。本気で考えなきゃ。

Win64

内容的にはこちらに記載した内容の続きです。
ファイル間リンクの取得10 - C#ATIA

VBA7はVBAのバージョンだとわかるのですが、Win64って何だろう?
と思い調べました。
コンパイラ定数 (VBA) | Microsoft Docs
正直に書くと以前は 「OSが64bitだよ」 って思ってました。
開発プラットフォームなんですね。

実は客先環境はCAAがガッツリ入っているんです。使わないんですけど。
調べてみても目ぼしい情報が無いのですが、こちらがHit
COE : Forums : Building CAA dll for 64 bit windows
XP時代の情報なのですが、そんなに外れてはいないはず。

そして一つ思い出した事が…
実はブログには書いていないのですが、こちらのマクロの続きを
作った際の体験です。
同一UUIDのDraw参照元ファイルを差し替える4 - C#ATIA
ひょっとしたら何処かに書いたかな?
あまりに使いにくかったので、FormでUIを作ったのですが、
その際、リストビューを使いました。
客先環境ではOKなのですが、通常の環境ではNGだったんです。
あの時は何が原因か全くわからなかったのですが、
「客先環境だけでしか使わないだろうからまぁ良いや」
と思っていたのですが、恐らくこれが原因だったのだろうと
思います。(64bitではリストビューが使えない)

試してみたら自宅のExcelもVBA7&Win32でした。この組み合わせは
あるんですね、普通に。(恐らく会社のExcelも)
Win64はソフトのコンパイル時の設定で決まるのだろうと思われます。
VisualStudio で実行ビット数を変更する