Drawﾋﾞｭｰの原点を変更する1

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

こんな3Dデータだとします。

オレンジ色が製品原点で、黄色が部品原点だとします。
実はオレンジ色は絶対座標系です。

2Dを作成する際、何も考えずに平面だけを指定して作業を始めました。

すいません、適当で･･･。この場合は、最初のオレンジ色（絶対座標系）
の位置が各ビューの原点になっています

ところが、「お前、何やっているんだ？部品原点を基準に寸法入れるに
決まっているだろ！」と言う事になった場合、どうするのでしょうか？

こちらに「投影平面を修正」コマンドがあるのですが、これはビューの
向きを修正してくれるのですが、原点は変更してくれないですよね？

探しても探しても原点を修正するコマンドが見つからず、サポートさんに
問い合わせても機能が無いと判りました。（その節はお世話になりました）

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

少し前に気になった、こちらのメソッドを利用するとビューの原点位置を
変更出来るのではないかな？　と感じていました。
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 で実行ビット数を変更する

オプションの設定を切り替える（発見手順）

最近こそ業務の依頼として頂くので、CATIAで2D図を使うようになったのですが
以前からあまり好きではなく、他の2DCADで構わないのであれば他のCADを
使っていました。その理由のひとつが（3Dから投影したもの以外の）線を
ドラッグした際動いちゃう事なんです。

でも、こちらのオプションの設定で固定できる事に気が付きました。

あ～便利だ、と思ったものの人間はわがままです。ちょっとだけ動かしたいなぁ
と思うんです。その都度オプション開いてONにし動かした後にOFFにするのは
面倒です。（そもそも移動コマンドがもっとまともなら、気にしないのですが）

オプションの設定を知る方法のひとつが、CATSettingsファイルを見る事なのですが
バイナリファイルな為、エディタで開いてもわかりません。
その為、XMLフォーマットに変換する為のプログラムが存在しています。

ここに記載されている、CATBatGenXMLSetがそうです。
Importing and Exporting Settings Files to/from XML Format
インストールフォルダ内のCATIAの実行ファイルと同じフォルダに
入っているはずです。
（逆に　XML→CATSettings　はCATBatImpXMLSetです。）
でも、個人的な感覚としてCATSettingsファイルは、CATIA起動時に
読み込んで終了時に書き出しており、起動中のCATIAに対しては
何の役にも立たないんです。上記のオプションをマクロで変更したい時
CATSettingsを書き換えても変わってくれないはずです。

マクロの記録をとっても空、Webで検索してもHit無しなので
困って諦めていたのですが、Helpを見るとここにパラメータ値を
エクスポートするボタンがあると記載が有りました。

エクスポートしてみると何と、catvbsファイルなんです。
これなら届きそうです。

1）変更したいオプションの変更前と変更後をエクスポート。
　上書きしてしまう為、一度行ったものをリネームして二度目を
　実行してください。

2）違いを比較。イロイロ方法はあると思うのですが、コマンドプロンプト
　を起動し、FCで比較しました。

ネーミングからしてもパラメータ名　”Drw_settings_DragElts”　が
怪しそうなのです。
エディタで開いてみると

まぁそうね、程度ですけど。

3）エクスポートしたcatvbsの先頭付近を参考にし、入力補完にも助けられ
こんな感じのコードを実行すると無事切り替わりました。

Sub CATMain()

    Dim setctl As SettingControllers
    Set setctl = CATIA.SettingControllers
    
    Dim setPpty As SettingRepository
    Set setPpty = setctl.Item("DraftingOptions")
    
    Dim bl As Boolean
    bl = IIf(setPpty.GetAttr("Drw_settings_DragElts"), _
            False, True)
    
    'ｷｬｽﾄする必要有り
    Call setPpty.PutAttr("Drw_settings_DragElts", CBool(bl))

End Sub

試していないので断言できないのですが、今回の事を考えると
マクロでオプションの設定を知ることも変更する事も、
全て可能なのではないかと思います。今更かな？

Select Case True

覚書です。

'vba
Select Case True

知った際に結構衝撃的だったのですが、先にTrueを条件にしてしまい
イロイロと異なる条件を元に判断してしまうのに利用しています。
（雰囲気的にYesマンみたいなｲﾒｰｼﾞです）

この記法は結構独特なのかと思っていたのですが、
C,C++,Java,Js等の switch(true) みたいな書き方はありそうです。
確かC#では確か出来なかったですし、Pythonではそもそも
switch、select case　の様な条件分岐が無いです。

まぁ、賛否は両論ですね。
switch(true) イディオム考察 - Qiita
自分は switch(true) イディオムを使ってなぜクソコードを書くのか - Qiita

Drawのﾋﾞｭｰがロックされているか？　を判断したい時に上手く
判断出来なかったです。

'vba　DrawingDocumentをｱｸﾃｨﾌﾞにして下さい
Option Explicit

Sub CATMain()
    
    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.selection
    
    Dim msg As String
    msg = "ﾋﾞｭｰを選択してください"
    
    sel.Clear
    Select Case sel.SelectElement2(Array("DrawingView"), msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Sub
    End Select
    
    Dim vi As DrawingView
    Set vi = sel.Item(1).Value
    
    Dim res As Boolean
    
    '正統派
    msg = "IF : "
    If vi.LockStatus Then
        Debug.Print msg & "Lock"
    Else
        Debug.Print msg & "UnLock"
    End If
    
    'こだわり派
    msg = "IIF : "
    msg = msg & IIf(vi.LockStatus, "Lock", "UnLock")
    Debug.Print msg
    
    '邪道派
    msg = "SELECT CASE : "
    Select Case True
        Case vi.LockStatus
            Debug.Print msg & "Lock"
        Case Else
            Debug.Print msg & "UnLock"
    End Select
End Sub

Drawをｱｸﾃｨﾌﾞにし、ﾛｯｸされていないﾋﾞｭｰを選択すると

IF : UnLock
IIF : UnLock
SELECT CASE : UnLock

でOKなんですが、ﾛｯｸされているﾋﾞｭｰを選択すると

IF : Lock
IIF : Lock
SELECT CASE : UnLock

"Select Case True"　だけが上手く判断出来ていないんです。
理由はわからないのですが、上手く行かないので避けておかなきゃ･･･。

ﾋﾞｭｰの場合、ﾛｯｸされていなくて、参照ﾋﾞｭｰをもっていなくて、
分離されていなくて･･･　の様に異なるプロパティを単純にクリアした
ものだけ処理したい場合は、

ELSE IF　→　ネストが深くなってイヤ（Excelの複雑な式みたいになると混乱する）
IFのOR　→　1行長い
IIF　→　条件内が長くなりIFと変わらない
ﾌﾗｸﾞ立てる　→　一度しか使わない変数を作りたくない

とイロイロ方法が有りそうなのですが、
クリアしなかった条件によって　”〇〇の条件が不足しています”
と警告したい場合に一番清楚に書けるのが "Select Case True" かな？
と思い、ここ数年は好んで使用していますがどうでしょう？
（今回は上手くいかなかったのですが）

2D属性リンクを扱いたい8

こちらの続きです。
2D属性リンクを扱いたい7 - C#ATIA

こちらの「GetLinksInfo.bas」でリンク情報が手に入ったので、
セルのオブジェクト名を書き込むのをやめて、リンク情報を書き込む
ことにします。
ﾌｧｲﾙ間ﾘﾝｸの取得9 - C#ATIA

'vba CheckAttributeLink Ver0.0.1
'using-'KCL0.0.13' 'GetLinksInfo ver0.0.2'  by Kantoku
'指定したDrawTableの隣に属性ﾘﾝｸ情報ﾃｰﾌﾞﾙを作成する

Option Explicit

'元ﾃｰﾌﾞﾙとのﾏｰｼﾞﾝ距離
Private Const MARGIN_X = 10#

Sub CATMain()
    Dim msg As String
    
    #If VBA7 And Win64 Then
        'ok
    #Else
        msg = "VBA環境が VBA7 & Win64 では無い為" & vbCrLf & _
            "正しく処理正しく処理出来ません!" & vbCrLf & _
            "中止します"
        MsgBox msg, vbExclamation
        Exit Sub
    #End If
    
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    'ﾃｰﾌﾞﾙ選択
    msg = "テーブル選択/ESCキー中止"
    
    Dim tblOri As DrawingTable
    Set tblOri = KCL.SelectItem(msg, "DrawingTable")
    If tblOri Is Nothing Then Exit Sub
    
    KCL.SW_Start
    
    '属性ﾘﾝｸ情報取得
    Dim links As Variant
    links = GetLinkInfo(tblOri)
    If UBound(links) < 1 Then
        MsgBox "ﾘﾝｸ情報が無い、又は取得に失敗しました"
        Exit Sub
    End If
    
    'ﾋﾞｭｰ取得
    Dim vi As DrawingView
    Set vi = tblOri.Parent.Parent
    
    'ﾃｰﾌﾞﾙｺﾋﾟﾍﾟ
    Dim tblNew As DrawingTable
    Set tblNew = CopyTable(tblOri, vi)
    If tblNew Is Nothing Then
        MsgBox "ﾃｰﾌﾞﾙのｺﾋﾟﾍﾟに失敗しました"
        Exit Sub
    End If
    
    '描写停止
    tblOri.ComputeMode = CatTableComputeOFF
    tblNew.ComputeMode = CatTableComputeOFF
    
    'ﾃｰﾌﾞﾙ幅取得
    Dim moveX As Double
    moveX = GetColumnSizeAll(tblNew)
    tblNew.X = (tblNew.X + moveX + MARGIN_X) / vi.scale2
    
    'ﾃｰﾌﾞﾙにｵﾌﾞｼﾞｪｸﾄ名記入
    'WriteCellName tblNew
    
    'ｾﾙ辞書作成
    Dim cellDic As Object
    Set cellDic = InitCellDic(tblOri, tblNew)
    If cellDic.count < 1 Then
        MsgBox "ｾﾙ情報の取得に失敗しました"
        GoTo fin
    End If
    
    'ﾘﾝｸ情報書き込み
    Call PushInfo(cellDic, links)
    
fin:
    '描写
    tblOri.ComputeMode = CatTableComputeON
    tblNew.ComputeMode = CatTableComputeON
    
    MsgBox "done : " & KCL.SW_GetTime & "s"
    
End Sub

Private Sub PushInfo( _
    ByVal dic As Object, _
    ByVal infos As Variant)
    
    Dim i As Long
    Dim dt As DrawingText
    For i = 0 To UBound(infos)
        If Not dic.Exists(infos(i)(0)) Then GoTo continue
        
        Set dt = dic.Item(infos(i)(0))
        dt.Text = dt.Text & vbCrLf & ConvPrmValue(infos(i)(1))
        dt.TextProperties.Bold = 1
continue:
    Next
    
End Sub

'先頭部(ﾊﾟｰﾄNo)削除
Private Function ConvPrmValue( _
    ByVal txt As String) _
    As String
    
    Dim idx As Long
    idx = InStr(txt, "\")
    
    If idx > 0 Then
        txt = Mid(txt, idx + 1)
    End If
    
    ConvPrmValue = txt
    
End Function


'ｾﾙの辞書作成 - ついでに初期化
'return:dic(key(string)-objName,value(drawtxt)-obj
Private Function InitCellDic( _
    ByVal tbOri As DrawingTable, _
    ByVal tbNew As DrawingTable) As Object
    
    Dim dic As Object
    Set dic = KCL.InitDic()
    
    Dim r As Long, c As Long
    Dim dt As DrawingText
    
    With tbNew
        For r = 1 To .NumberOfRows
            For c = 1 To .NumberOfColumns
                'Existsしなくても大丈夫なはず
                Set dt = .GetCellObject(r, c)
                dt.TextProperties.Bold = 0
                dic.Add tbOri.GetCellObject(r, c).Name, dt
            Next
        Next
    End With
    
    Set InitCellDic = dic
    
End Function


Private Function GetLinkInfo( _
    ByVal tb As DrawingTable) As Variant
    
    Dim sel As selection
    Set sel = CATIA.ActiveDocument.selection
    
    CATIA.HSOSynchronized = False
    
    sel.Clear
    sel.Add tb
    
    Dim ary As Variant
    ary = GetLinksInfo.GetInfo()
    
    sel.Clear
    
    CATIA.HSOSynchronized = True
    
    GetLinkInfo = ary
    
End Function



Private Function CopyTable( _
    ByVal tb As DrawingTable, _
    ByVal vi As DrawingView) _
    As DrawingTable
    
    Dim sel As selection
    Set sel = CATIA.ActiveDocument.selection
        
    CATIA.HSOSynchronized = False
    
    With sel
        .Clear
        .Add tb
        .Copy
        .Clear
        .Add vi
        .Paste
        Set CopyTable = .Item2(1).Value
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
End Function

Private Function GetColumnSizeAll( _
    ByVal tb As DrawingTable) As Double
    
    Dim sumClm As Double
    sumClm = 0#
    
    Dim i As Long
    For i = 1 To tb.NumberOfColumns
        sumClm = sumClm + tb.GetColumnSize(i)
    Next
    
    GetColumnSizeAll = sumClm
    
End Function

前回同様、右側に新たなﾃｰﾌﾞﾙを作ります。
セル内の属性ﾘﾝｸを持っているものは、フォントのBoldがON状態に
なり、元の値の下に属性リンクのパスが書き込まれます。
パスをそのまま書き込みだと長ったらしい為、
PartNo以降のパスとしています。

劇的に確認作業が楽になりましたよ！
客先環境下では諦めた･･･。

ﾌｧｲﾙ間ﾘﾝｸの取得10

こちらの続きです。
ﾌｧｲﾙ間ﾘﾝｸの取得9 - C#ATIA

客先の環境下でリンク情報の取得が出来ません････。
もがきまくった末わかったのが、このコードで

Sub Win64Check()
    #If Win64 Then
        Debug.Print "Win64です"
    #Else
        Debug.Print "Win64じゃ有りません"
    #End If
End Sub

通常にインストールした環境下では、

"Win64です"

客先の環境下では

"Win64じゃ有りません"

です・・・。

客先の環境下は、CATIA自体をインストールするわけではなく
環境だけを作成しているような感じで･･･。
VBAに関係しそうなオプションの設定はエディタ等ぐらいなので
環境変数が影響しているのかな？どれだろう･･･。

ﾌｧｲﾙ間ﾘﾝｸの取得9

こちらの続きです。
ﾌｧｲﾙ間ﾘﾝｸの取得8 - C#ATIA

ここがゴールでは無いのですが、ﾌｧｲﾙ間ﾘﾝｸ情報をVBAで取得出来るようになりました。
こちらは、ﾘﾝｸ情報を取得するだけのものです。
WinAPIを利用している為、標準ﾓｼﾞｭｰﾙで作成してください。

'vba GetLinksInfo.bas ver0.0.2  by Kantoku
'これ自体はKCLには依存していません
'ﾘﾝｸﾀﾞｲｱﾛｸﾞのﾃｰﾌﾞﾙを配列として取得

'ver0.0.1:完成 日本語と英語のみ対応
'ver0.0.2:言語判定精度改善,64bitﾁｪｯｸ追加

Option Explicit

'--- win api ---
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'--
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) _
    As Long

'--
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" ( _
    ByVal hwnd As LongPtr, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Any _
    ) As Long

Private Declare PtrSafe Function SendMessageStr Lib "user32" Alias "SendMessageW" ( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As String) _
    As Long

Private Declare PtrSafe Function SendMessageAny Lib "user32" Alias "SendMessageW" ( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) _
    As Long

Private Const WM_GETTEXT = &HD
Private Const HDM_GETITEMCOUNT = (&H1200 + 0)
Private Const WM_CLOSE = &H10

Private Const LVM_FIRST As Long = &H1000
Private Const LVM_GETITEMCOUNT = (LVM_FIRST + 4)
Private Const LVM_GETITEM As Long = (LVM_FIRST + 5)
Private Const LVM_GETHEADER = (LVM_FIRST + 31)
Private Const LVM_SETITEMSTATE = (LVM_FIRST + 43)
Private Const LVM_GETITEMSTATE = (LVM_FIRST + 44)
Private Const LVM_GETITEMTEXT = LVM_FIRST + 45

'--
Private Declare PtrSafe Function EnumChildWindows Lib "user32" ( _
    ByVal hWndParent As LongPtr, _
    ByVal lpEnumFunc As LongPtr, _
    ByVal lParam As Long) _
    As Long
    
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
    ByVal hwnd As LongPtr, _
    ByVal nCmdShow As Long) _
    As Long
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5
    
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) _
    As LongPtr

Private Declare PtrSafe Function GetWindow Lib "user32" ( _
    ByVal hwnd As LongPtr, _
    ByVal wCmd As Long) _
    As LongPtr
Private Const GW_HWNDNEXT = 2

Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpString As String, _
    ByVal cch As Long) _
    As Long

Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () _
    As LongPtr
    
'--
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" ( _
    ByVal hwnd As LongPtr, _
    lpdwProcessId As Long) _
    As Long

'--
Private Declare PtrSafe Function OpenProcess Lib "kernel32" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) _
    As LongPtr
    
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20

'--
Private Declare PtrSafe Function VirtualAllocEx Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flAllocationType As Long, _
    ByVal flProtect As Long) _
    As LongPtr
    
Private Declare PtrSafe Function VirtualFreeEx Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    lpAddress As Any, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long) _
    As LongPtr
    
Private Const PAGE_READWRITE = &H4&

Private Const MEM_RESERVE = &H2000
Private Const MEM_COMMIT = &H1000
Private Const MEM_RELEASE = &H8000

'--
Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As LongPtr) _
    As Long

Private Declare PtrSafe Function ReadProcessMemory Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    lpBaseAddress As Any, _
    lpBuffer As Any, _
    ByVal nSize As LongPtr, _
    lpNumberOfBytesWritten As LongPtr) _
    As Long

Private Declare PtrSafe Function WriteProcessMemory Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    lpBaseAddress As Any, _
    lpBuffer As Any, _
    ByVal nSize As LongPtr, _
    lpNumberOfBytesWritten As LongPtr) _
    As Long

'-- ﾘｽﾄﾋﾞｭｰ用　構造体
Private Type LVITEM
    mask As Long
    iItem As Long
    iSubitem As Long
    state As Long
    stateMask As Long
    pszText As LongPtr
    cchTextMax As Long
    iImage As Long
    lParam As LongPtr
    iIndent As Long
End Type
Private Const LVIF_TEXT = &H1

'--
Private mLst_hwnd As LongPtr 'ﾘﾝｸﾀﾞｲｱﾛｸﾞ内ﾘｽﾄﾋﾞｭｰﾊﾝﾄﾞﾙ
Private mLstCount As Long 'ﾘﾝｸﾀﾞｲｱﾛｸﾞ内ﾘｽﾄﾋﾞｭｰ検索用

'言語別ｺﾏﾝﾄﾞ,ﾀﾞｲｱﾛｸﾞ文字列
'return:ary (0)-ｺﾏﾝﾄﾞ (1)-未選択時のﾀﾞｲｱﾛｸﾞ名称 (2)-選択時のﾀﾞｲｱﾛｸﾞ名称
Private Function GetCommandKey() _
    As Variant
    
    Dim ary As Variant
    Select Case GetLanguage
        Case "en"
            ary = Array("Links...", "Links of document", "Links of element")
        Case "ja"
            ary = Array("ﾘﾝｸ...", "ﾄﾞｷｭﾒﾝﾄのﾘﾝｸ", "ｴﾚﾒﾝﾄのﾘﾝｸ")
        Case Else
            ary = Array()
    End Select
    
    GetCommandKey = ary
End Function


'ﾘﾝｸﾀﾞｲｱﾛｸﾞのﾃｰﾌﾞﾙを配列として取得
Function GetInfo() _
    As Variant
    
    '64bit check
    #If VBA7 And Win64 Then
        'ok
    #Else
        msg = "VBA環境が VBA7 & Win64 では無い為" & vbCrLf & _
            "正しく処理正しく処理出来ません!" & vbCrLf & _
            "中止します"
        MsgBox msg, vbExclamation
        Exit Function
    #End If
    
    '初期化
    GetInfo = Array()
    mLstCount = 0
    Dim msg As String
    
    Dim cmdkey As Variant
    cmdkey = GetCommandKey()
    If UBound(cmdkey) < 1 Then
        msg = "CATIAの言語判定が出来ない" & vbCrLf & _
            "又は、未対応の言語設定です"
        MsgBox msg, vbExclamation
        Exit Function
    End If
    
    Dim dlgkey As String
    If CATIA.ActiveDocument.Selection.Count2 < 1 Then
        dlgkey = cmdkey(1)
    Else
        dlgkey = cmdkey(2)
    End If
    
    'ｺﾏﾝﾄﾞ実行
    CATIA.StartCommand CStr(cmdkey(0))
    CATIA.RefreshDisplay = True
    
    'ﾘﾝｸﾀﾞｲｱﾛｸﾞ取得
    Dim hwnd As LongPtr 'ﾘﾝｸﾀﾞｲｱﾛｸﾞﾊﾝﾄﾞﾙ
    hwnd = FindWindowLike(dlgkey)
    ShowWindow hwnd, SW_HIDE
    If hwnd < 1 Then Exit Function
    
    'ﾘﾝｸﾀﾞｲｱﾛｸﾞ内のﾘｽﾄﾋﾞｭｰ(SysListView32)ﾊﾝﾄﾞﾙ取得
    Sleep 100
    Call EnumChildWindows(hwnd, AddressOf CallBack_FindChildWindow, 0)
    If mLst_hwnd < 1 Then Exit Function
    
    'Row数
    Dim rows As Long
    rows = SendMessageStr(mLst_hwnd, LVM_GETITEMCOUNT, 0, 0)
    
    'ﾘｽﾄﾋﾞｭｰﾍｯﾀﾞｰのﾊﾝﾄﾞﾙ取得 : Column数取得に必要
    Dim h_hwnd As Long
    h_hwnd = SendMessageStr(mLst_hwnd, LVM_GETHEADER, 0, 0)

    'Column数
    Dim cols As Long
    cols = SendMessageStr(h_hwnd, HDM_GETITEMCOUNT, 0, 0)
    If rows < 1 Then Exit Function
    
    
    'ｾﾙ値取得
    Dim infos() As Variant
    ReDim infos(rows - 1)
    
    Dim info() As String
    Dim r As Long, c As Long
    For r = 0 To rows - 1
        ReDim info(cols - 1)
        For c = 0 To cols - 1
            info(c) = GetCellValue(mLst_hwnd, r, c)
        Next
        infos(r) = info
    Next
        
    'ﾘﾝｸﾀﾞｲｱﾛｸﾞ閉じる
    ShowWindow hwnd, SW_SHOW
    Call SendMessage(hwnd, WM_CLOSE, 0, ByVal 0&)
    
    GetInfo = infos
    'MsgBox UBound(infos)
    
End Function

'ｾﾙ値取得
Private Function GetCellValue( _
    ByVal hwnd As LongPtr, _
    ByVal row As Long, _
    ByVal clm As Long) _
    As String
    
    'ﾌﾟﾛｾｽID
    Dim prcId As Long
    Call GetWindowThreadProcessId(hwnd, prcId)
    If prcId = 0 Then
        Debug.Print "ﾌﾟﾛｾｽID NG"
        Exit Function
    End If
    
    'ﾌﾟﾛｾｽﾊﾝﾄﾞﾙ
    Dim prcHwnd As LongPtr
    prcHwnd = OpenProcess(PROCESS_VM_OPERATION Or _
                          PROCESS_VM_READ Or _
                          PROCESS_VM_WRITE, _
                          False, _
                          prcId)
    If prcHwnd = 0 Then
        Debug.Print "ﾌﾟﾛｾｽﾊﾝﾄﾞﾙ NG"
        Exit Function
    End If
    
    '書き出し準備
    Dim txtVi As String
    txtVi = String(255, vbNullChar)
    'txtVi = Space$(255)
    Dim txtViPtr As LongPtr
    txtViPtr = StrPtr(txtVi)
    
    Dim txtViSiz As LongPtr
    txtViSiz = LenB(txtVi)
    
    Dim txtViAlc As LongPtr
    txtViAlc = VirtualAllocEx(prcHwnd, _
                              0&, _
                              txtViSiz, _
                              MEM_RESERVE Or MEM_COMMIT, _
                              PAGE_READWRITE)
    
    Dim typLstItm As LVITEM
    
    Dim typViPtr As LongPtr
    typViPtr = VarPtr(typLstItm)
    
    Dim typViSiz As LongPtr
    typViSiz = LenB(typLstItm)
    
    Dim typViAlc As LongPtr
    typViAlc = VirtualAllocEx(prcHwnd, _
                              0&, _
                              typViSiz, _
                              MEM_RESERVE Or MEM_COMMIT, _
                              PAGE_READWRITE)
    
    With typLstItm
        .cchTextMax = 255
        .iItem = row
        .iSubitem = clm
        .mask = LVIF_TEXT
        .pszText = txtViAlc
    End With
    
    '書き出し
    Call WriteProcessMemory(prcHwnd, _
                            ByVal txtViAlc, _
                            ByVal txtViPtr, _
                            txtViSiz, _
                            0)
                            
    Call WriteProcessMemory(prcHwnd, _
                            ByVal typViAlc, _
                            ByVal typViPtr, _
                            typViSiz, _
                            0)
                            
    Call SendMessageAny(hwnd, _
                        LVM_GETITEM, _
                        ByVal 0, _
                        ByVal typViAlc)
    'ここ
    Call ReadProcessMemory(prcHwnd, _
                           ByVal txtViAlc, _
                           ByVal txtViPtr, _
                           txtViSiz, _
                           0)
    
    '値取得
    'vbFromUnicode
    'txtVi = StrConv(txtVi, vbUnicode, 1041)
    txtVi = StrConv(txtVi, vbUnicode)
    'txtVi = StrConv(txtVi, vbWide)
    GetCellValue = Left(txtVi, InStr(1, txtVi, vbNullChar) - 1)
    
    'ﾌﾟﾛｾｽ終了
    Call VirtualFreeEx(prcHwnd, _
                       ByVal txtViAlc, _
                       txtViSiz, _
                       MEM_RELEASE)
                       
    Call VirtualFreeEx(prcHwnd, _
                       ByVal typViAlc, _
                       typViSiz, _
                       MEM_RELEASE)
                       
    Call CloseHandle(prcHwnd)
            
End Function

'ﾀﾞｲｱﾛｸﾞ内ﾘｽﾄﾋﾞｭ-
Private Function CallBack_FindChildWindow( _
    ByVal hwnd As LongPtr, _
    ByVal prm As Long) _
    As Long

    Dim cls As String
    cls = String(255, vbNullChar)
    
    Dim cnt As Long
    cnt = GetClassName(hwnd, cls, 63&)
    cls = Left(cls, cnt)
    
    If cls = "SysListView32" Then
        mLstCount = mLstCount + 1
        If mLstCount > 1 Then '2個目のﾘｽﾄﾋﾞｭｰ
            mLst_hwnd = hwnd
            CallBack_FindChildWindow = 0
            Exit Function
        End If
    End If
    CallBack_FindChildWindow = 1 '終了ｻｲﾝ
    
End Function

'指定文字を含んだWindow取得
Private Function FindWindowLike( _
    key As String) _
    As LongPtr
    
    Dim hwnd As LongPtr
    Dim winTxt As String
    Dim cnt As Integer
    hwnd = GetForegroundWindow
    
    Do Until hwnd = 0
        winTxt = String(255, vbNullChar)
        cnt = GetWindowText(hwnd, winTxt, 255)
        winTxt = Left(winTxt, cnt)
        
        If InStr(1, LCase(winTxt), LCase(key)) > 0 Then Exit Do
        hwnd = GetWindow(hwnd, GW_HWNDNEXT)
    Loop
    FindWindowLike = hwnd
    
End Function

'言語判定
Private Function GetSelectedItems() _
    As Collection
    
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim i As Long
    For i = 1 To sel.Count2
        lst.Add sel.Item2(i).Value
    Next
    
    Set GetSelectedItems = lst
    
End Function

Private Sub SetSelectItems( _
    ByVal lst As Collection)
    
    If lst.count < 1 Then Exit Sub
    
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    CATIA.HSOSynchronized = False
    
    Dim elm As AnyObject
    For Each elm In lst
        sel.Add elm
    Next
    
    CATIA.HSOSynchronized = True
    
End Sub


'言語判定
Private Function GetLanguage() _
    As String
    
    GetLanguage = "non"
    If CATIA.Windows.count < 1 Then Exit Function
    
    GetLanguage = "other"
    
    Dim lst As Collection
    Set lst = GetSelectedItems()
    
    CATIA.ActiveDocument.Selection.Clear
    SendKeys "{ESC}"
    Sleep 100
    SendKeys "{ESC}"
    CATIA.RefreshDisplay = True
    
    Dim st As String
    st = CATIA.StatusBar
    
    Select Case True
        Case ExistsKey(st, "object")
            GetLanguage = "en"
        Case ExistsKey(st, "objet")
            GetLanguage = "fr"
        Case ExistsKey(st, "Objekt")
            GetLanguage = "de"
        Case ExistsKey(st, "oggetto")
            GetLanguage = "it"
        Case ExistsKey(st, "ｵﾌﾞｼﾞｪｸﾄ")
            GetLanguage = "ja"
        Case ExistsKey(st, "объект")
            GetLanguage = "ru"
        Case ExistsKey(st, "象或")
            GetLanguage = "zh"
        Case Else
            Select Case Len(st)
                Case 13
                    GetLanguage = "ko"
                Case 23
                    GetLanguage = "ja"
                Case Else
                
            End Select
    End Select
    
    Call SetSelectItems(lst)
    
End Function

Private Function ExistsKey( _
    ByVal txt As String, _
    ByVal key As String) _
    As Boolean
    
    ExistsKey = IIf(InStr(LCase(txt), LCase(key)) > 0, _
        True, _
        False)
End Function

WinAPIがグリグリゴリゴリで吐き気がしそうなやつです。
”もうちょっとこうしたら効率が良いんじゃないの？”
と言うご意見があれば教えて頂けると助かります。
（動いたからもう見たくない）

GetInfo関数を呼び出すと、アクティブなドキュメントのリンク情報を配列で
受け取れます。

戻り値の配列の状態は
array(赤側のｲﾝﾃﾞｯｸｽ)(緑側のｲﾝﾃﾞｯｸｽ)
で全てString型です。（緑側は0～9の10個固定になるはず）

StartCommandを利用している為、CATIAの言語に依存されますが、
一応、日本語、英語は対応させています。日本語のみ確認しています。
日本語、英語は対応させています。但し、VBA7、WIN64が条件です。
こちらを参照してください。（当方OS:Win7 64bit Catia V5-6 R2015）
ﾌｧｲﾙ間ﾘﾝｸの取得10 - C#ATIA
（他言語は要望があれば追加しますが、面倒です）

又、C#時にはドキュメント全体のリンク情報しか取得できませんでしたが、
VBA版はオブジェクトを選択した状態でGetInfo関数を呼び出すと、
そのオブジェクトのリンク情報のみを取得出来るようにしています。
（感覚的に手動時と同じ挙動の方が自然ですよね？）

こちらは上記の利用したｻﾝﾌﾟﾙです。

'vba sample_GetLinksInfo
'using-'KCL0.0.13','GetLinksInfo'  by Kantoku

'GetLinksInfoを使ったｻﾝﾌﾟﾙです
'手動同様に何も選択していなければｱｸﾃｨﾌﾞなDocumentの全ﾘﾝｸ情報
'選択していれば、選択しているものだけのﾘﾝｸ情報を
'ﾌｧｲﾙと同一のﾌｫﾙﾀﾞにCSVﾌｧｲﾙで出力します


Sub CATMain()

    Dim msg As String
    
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    Dim filter As String
    filter = "DrawingDocument,PartDocument,ProductDocument"
    If Not CanExecute(filter) Then Exit Sub
    
    'Doc
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    '出力ﾊﾟｽ
    Dim path As String
    path = doc.FullName
    If InStr(1, path, "\") < 1 Then
        msg = "出力ﾊﾟｽが確定しない為、一度保存してください!"
        MsgBox msg, vbExclamation
        Exit Sub
    End If
    
    Dim dmy As Variant
    dmy = KCL.SplitPathName(path)
    dmy(1) = dmy(1) & "_LinksInfo"
    dmy(2) = "csv"
    
    Dim exp As String
    exp = KCL.GetNewName(KCL.JoinPathName(dmy))
    
    '確認
    msg = "ﾘﾝｸ情報を出力しますか？"
    If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then Exit Sub
    
    Dim infos As Variant
    infos = GetLinksInfo.GetInfo()
    
    If UBound(infos) < 1 Then
        msg = "外部ﾘﾝｸが無い、又は正常に取得できませんでした!"
        MsgBox msg, vbExclamation
        Exit Sub
    End If
    
    '書き出し
    Call KCL.WriteFile(exp, Info2Str(infos))
    
    '終わり
    MsgBox "done"
    
End Sub

Private Function Info2Str( _
    ary As Variant)
    
    Dim ex() As Variant
    ReDim ex(UBound(ary))
    
    Dim i As Long
    For i = 0 To UBound(ary)
        ex(i) = Join(ary(i), ",")
    Next
    
    Info2Str = Join(ex, vbCrLf)
    
End Function

DrawingDocument,PartDocument,ProductDocument問わず、
アクティブなドキュメントと同じフォルダ内に、リンク情報の
CSVファイルを作成します。
選択時、未選択時で出力される内容が変わることが確認出来ると
思います。

もうちょっとで届きそう！

※Ver0.0.2にしました。言語判定精度改善,64bitﾁｪｯｸ追加