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

こちらの続きです。
ﾌｧｲﾙ間ﾘﾝｸの取得2 - C#ATIA
3年程前に断念したVBAでのﾌｧｲﾙ間ﾘﾝｸ情報取得なのですが、
昨日から少し手ごたえを感じています。

元にしているコードはこちらです。
Catia V5 Get Links
過去に紹介したサイトが幾つも消えてしまっているのですが、
消えていなくて助かっています。が、あまりにコードが汚いのも本音です。

「ﾘﾝｸ...」（英語環境 Links...）ｺﾏﾝﾄﾞを実行し、出てくるﾀﾞｲｱﾛｸﾞの情報を
WinAPIでゴリゴリに取得しようと言うマクロなのですが、大元は32bitの頃に
作成されたもので、前回取り組んだ際はOSが64bitでVBAが32bitだったような
記憶です。

まだ途中ですが、ﾀﾞｲｱﾛｸﾞのﾘｽﾄﾋﾞｭｰにｱｸｾｽする辺りまでのコードです。

'vba ﾘﾝｸﾀﾞｲｱﾛｸﾞ取得ﾃｽﾄ

Option Explicit

'--- win api ---
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 "SendMessageA" ( _
    ByVal hwnd As LongPtr, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Any _
    ) As Long 'Ptr

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

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

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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'--
Private F_hwnd As LongPtr
Private L_hwnd As LongPtr
Private ListCount As Long

Sub CATMain()

    'ｺﾏﾝﾄﾞ実行
    CATIA.StartCommand ("ﾘﾝｸ...") ' ("Links...") '
    CATIA.RefreshDisplay = True
    
    'ﾘﾝｸﾀﾞｲｱﾛｸﾞ取得
    F_hwnd = FindWindowLike("ﾄﾞｷｭﾒﾝﾄのﾘﾝｸ") '("Links of document") '
    'ShowWindow F_hwnd, SW_HIDE
    
    'ﾘﾝｸﾀﾞｲｱﾛｸﾞ内のﾘｽﾄﾋﾞｭｰ(SysListView32)ﾊﾝﾄﾞﾙ取得
    Sleep 100
    Call EnumChildWindows(F_hwnd, AddressOf EnumChildWindow, 0)
    
    'Row数
    Dim rows As Long
    rows = SendMessageStr(L_hwnd, LVM_GETITEMCOUNT, 0, 0)
    
    'ﾘｽﾄﾋﾞｭｰﾍｯﾀﾞｰのﾊﾝﾄﾞﾙ取得 : Column数取得に必要
    Dim hWndHeader As Long 'Long
    hWndHeader = SendMessage(L_hwnd, LVM_GETHEADER, 0, ByVal 0&)
    
    'Column数
    Dim cols As Long
    cols = SendMessageStr(hWndHeader, HDM_GETITEMCOUNT, 0, 0)
        
    'ﾘﾝｸﾀﾞｲｱﾛｸﾞ閉じる
    'ShowWindow F_hwnd, SW_SHOW
    SendMessageAny F_hwnd, WM_CLOSE, 0, 0
    
    Stop
End Sub

Private Function EnumChildWindow( _
    ByVal hChild As LongPtr, _
    ByVal lParam As LongPtr) _
    As Long
    
    Dim iClass As String
    Dim iText As String
    Dim j As LongPtr
    
    iClass = String(255, vbNullChar) 'Space(256)
    j = GetClassName(hChild, iClass, 63)
    iClass = Left(iClass, CLng(j))
    iText = String(255, vbNullChar) 'Space(256)
    j = SendMessageStr(hChild, WM_GETTEXT, 255, iText)
    iText = Left(iText, CLng(j))
    If iClass = "SysListView32" Then
        ListCount = ListCount + 1
        If ListCount = 2 Then
            L_hwnd = hChild: EnumChildWindow = 0: Exit Function
        End If
    End If
    EnumChildWindow = 1 ' Continua enumerarea
    
End Function

Private Function FindWindowLike( _
    strPartOfCaption As String) _
    As LongPtr
    
    Dim hwnd As LongPtr
    Dim strCurrentWindowText As String
    Dim r As Integer
    hwnd = GetForegroundWindow
    Do Until hwnd = 0
        strCurrentWindowText = String(255, vbNullChar) 'Space(256)
        r = GetWindowText(hwnd, strCurrentWindowText, 255)
        strCurrentWindowText = Left$(strCurrentWindowText, r)
        If InStr(1, LCase(strCurrentWindowText), LCase(strPartOfCaption)) <> 0 Then GoTo Found
        hwnd = GetWindow(hwnd, GW_HWNDNEXT)
    Loop
    Exit Function
Found:
    FindWindowLike = hwnd
    
End Function

正直な所、
・WinAPIの引き数・戻り値の型に自信が有りません
・EnumChildWindow、FindWindowLikeは動くレベルまでの
　修正しかしていません。

実際に実行してみるとこんな感じです。

ﾛｰｶﾙｳｨﾝﾄﾞｳに表示されているものは、ﾘﾝｸのﾀﾞｲｱﾛｸﾞに入っている
ﾘｽﾄﾋﾞｭｰの行と列の数等で、それなりに取得できているのがわかります。
（あまりに汚いのでコードを記載していませんが、その後のｺｰﾄﾞで
　ﾘﾝｸ情報は全て取得出来ています）

悩んでいるのは、2度目以降実行すると

数値が取得出来なくなります。何故？

単に取得する際のSendMessage類が機能しないのか？
一回目の実行後の終了の仕方が悪いのか？
何をどうすれば良いのか･･･。

但し、この様な操作をすると、再度取得が出来ます。
例えば、WinAPIのSendMessage関数の戻り値の型をこんな感じに
修正します。

Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" ( _
・・・
    ) As Long 'Ptr

　↓

    ) As LongPtr

当然、SendMessage関数の利用先では型の不一致でエラーとなります。
そこで、SendMessage関数の戻り値の型を元に戻すと再び正しく取得出来ます。
但し1度だけです。

感覚的に、宣言セクションにある程度影響のある修正を加えると、1度だけ
正しく取得出来ているような感じです。

どうでも良い部分にスペースを入れて、削除ぐらいではダメなんですが。

この様な現象を経験された方いらっしゃいませんか？
どの様に対策を取れば良いのだろう？
不安定な挙動なので、何かしらが正しくなくてギリギリ動いているのは
実感しているのですが、ゴールへの道筋があるのに辿り着けない･･･。

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

こちらの
2D属性リンクを扱いたい6 - C#ATIA

ですが、内容的にはこちらを変更したものです。
2D属性リンクを扱いたい4 - C#ATIA

前回CSVファイルとしてエクスポートしたのですが、
同じレイアウトでセルのオブジェクト名を記載したテーブルを
横に作成した方が確認が楽な事に気が付きました。

'vba sample_CreateCellNameTable using-'KCL0.0.13'  by Kantoku
'指定したDrawTableを隣にｺﾋﾟﾍﾟしｾﾙのｵﾌﾞｼﾞｪｸﾄ名を書き出す

Option Explicit

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

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    'ﾃｰﾌﾞﾙ選択
    Dim msg As String
    msg = "テーブル選択/ESCキー中止"
    
    Dim dwTblOri As DrawingTable
    Set dwTblOri = KCL.SelectItem(msg, "DrawingTable")
    If dwTblOri Is Nothing Then Exit Sub
    
    'ﾃｰﾌﾞﾙｺﾋﾟﾍﾟ
    Dim dwTblNew As DrawingTable
    Set dwTblNew = CopyTable(dwTblOri)
    If dwTblNew Is Nothing Then
        MsgBox "ﾃｰﾌﾞﾙのｺﾋﾟﾍﾟに失敗しました"
        Exit Sub
    End If
    
    'ﾃｰﾌﾞﾙ幅取得
    Dim moveX As Double
    moveX = GetColumnSizeAll(dwTblNew)
    dwTblNew.X = dwTblNew.X + moveX + MARGIN_X
    
    'ﾃｰﾌﾞﾙにｵﾌﾞｼﾞｪｸﾄ名記入
    WriteCellName dwTblNew
    
    MsgBox "done"
    
End Sub

Private Sub WriteCellName( _
    ByVal table As DrawingTable)
    
    Dim r As Long, c As Long
    
    With table
        For r = 1 To .NumberOfRows
            For c = 1 To .NumberOfColumns
                .SetCellString r, c, .GetCellObject(r, c).name
            Next
        Next
    End With
    
End Sub

Private Function CopyTable( _
    ByVal table As DrawingTable) _
    As DrawingTable
    
    Dim sel As selection
    Set sel = CATIA.ActiveDocument.selection
    
    Dim vi As DrawingView
    Set vi = KCL.GetParent_Of_T(table, "DrawingView")
    If vi Is Nothing Then Exit Function
    
    CATIA.HSOSynchronized = False
    
    With sel
        .Clear
        .Add table
        .Copy
        .Clear
        .Add vi
        .Paste
        Set CopyTable = .Item2(1).Value
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
End Function

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

レイアウトは元のテーブルと同じで、隣にセル名の入ったテーブルを
作ります。

後は、やっぱりチマチマと確認です･･･。

新たに作成したテーブルは元のテーブルをｺﾋﾟﾍﾟして
セルの中身を書き換えただけの為、こちらの問題から
属性ﾘﾝｸが残っています。
2D属性リンクを扱いたい2 - C#ATIA
未だに属性ﾘﾝｸをﾏｸﾛで削除する方法が見つかりません。

又、一部KCLの関数がエラーになり止まってしまう事がシバシバ
起きているので、こっそりVer0.0.12　→　Ver0.0.13　に更新しました。
（例外入れただけです）
非常に個人的なCATVBA用ﾗｲﾌﾞﾗﾘ - C#ATIA

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

こちらの続きです。
2D属性リンクを扱いたい5 属性ﾘﾝｸ付き座標ﾃｰﾌﾞﾙ - C#ATIA

処理が満足出来るレベルまで速くなりました。

'vba AttributeLinkTable Ver0.0.2 using-'KCL0.0.12'  by Kantoku
'属性リンク付き座標テーブル-平面上の点のみ対応

'ver0.0.1:完成
'ver0.0.2:ﾀｲﾄﾙを形状ｾｯﾄ名に変更,高速化

Private Const KEY_H = "H"               'ﾊﾟﾗﾒｰﾀ用Hｷｰ
Private Const KEY_V = "V"               'ﾊﾟﾗﾒｰﾀ用Vｷｰ
Private Const ROWSIZE = 10              'ﾃｰﾌﾞﾙ初期行高さ
Private Const COLUMNSIZE = 35           'ﾃｰﾌﾞﾙ初期列幅

Option Explicit

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    'ﾋﾞｭｰ選択
    Dim msg As String
    msg = "ﾃｰﾌﾞﾙを作成する、ﾋﾞｭｰを選択してください /ESC-終了"
    
    Dim vi As DrawingView
    Set vi = KCL.SelectItem(msg, "DrawingView")
    If vi Is Nothing Then Exit Sub
    
    '形状ｾｯﾄ選択
    msg = "平面上の点を含んだ、形状ｾｯﾄを選択してください /ESC-終了"
    
    Dim hBdy As HybridBody
    Set hBdy = SelectItem4(msg, msg, Array("HybridBody"))
    If hBdy Is Nothing Then Exit Sub
    
    'time
    KCL.SW_Start
    
    'ﾘﾝｸPart取得
    Dim lnkPt As Part
    Set lnkPt = KCL.GetParent_Of_T(hBdy, "Part")
    If lnkPt Is Nothing Then
        MsgBox "形状ｾｯﾄのPartが取得できませんでした"
        Exit Sub
    End If
    
    'ﾊﾟﾗﾒｰﾀ名取得
    Dim prms As Variant
    prms = GetParameters(hBdy)
    If IsEmpty(prms) Then
        msg = "処理すべき点が含まれていませんでした" & vbCrLf & _
            "（平面上の点のみ対応してます）"
        MsgBox msg
        Exit Sub
    End If
    
    'ﾃｰﾌﾞﾙ作成&書き込み
    Call InitTable(prms, vi, hBdy.name)
    
    MsgBox "done : " & KCL.SW_GetTime
    
End Sub

'ﾃｰﾌﾞﾙ作成し投げ込む
Private Sub InitTable( _
    ByVal prms As Variant, _
    ByVal vi As DrawingView, _
    ByVal title As String)
    
    'row
    Dim rowcnt As Long
    rowcnt = UBound(prms)
    
    'Column
    Dim clmcnt As Long
    clmcnt = UBound(prms(0))
    
    'ﾃｰﾌﾞﾙ
    Dim tbl As DrawingTable
    Set tbl = vi.Tables.Add(0, 0, rowcnt + 2, clmcnt + 1, ROWSIZE, COLUMNSIZE) 

    'タイトル
    Dim titles As Variant
    titles = Array(title, KEY_H, KEY_V)
    
    Dim dt As DrawingText
    Dim c As Long
    For c = 0 To clmcnt
        Set dt = tbl.GetCellObject(1, c + 1)
        dt.Text = titles(c)
    Next
    
    '書き出し
    Dim r As Long
    tbl.ComputeMode = CatTableComputeOFF
    For r = 0 To rowcnt
        Set dt = tbl.GetCellObject(r + 2, 1)
        dt.Text = prms(r)(0)
        
        For c = 1 To clmcnt
            Set dt = tbl.GetCellObject(r + 2, c + 1)
            Call dt.InsertVariable(0, 0, prms(r)(c))
        Next
    Next
    tbl.ComputeMode = CatTableComputeON
    
End Sub

'形状ｾｯﾄ内の点からﾊﾟﾗﾒｰﾀを取得
Private Function GetParameters( _
    ByVal hBdy As HybridBody) As Variant
    
    Dim shps As HybridShapes
    Set shps = hBdy.HybridShapes
    
    'HybridShapePointOnPlaneのみ
    Dim lst As Collection
    Set lst = New Collection
    
    Dim shp As HybridShape
    Dim i As Long
    For i = 1 To shps.Count
        If Not typename(shps.Item(i)) = "HybridShapePointOnPlane" Then
            GoTo continue
        End If
        
        lst.Add shps.Item(i)
continue:
    Next
    
    If lst.Count < 1 Then Exit Function '点なし
    
    
    'HVﾊﾟﾗﾒｰﾀを取得
    Dim pt As Part
    Set pt = KCL.GetParent_Of_T(hBdy, "Part")
    
    Dim prms As Parameters
    Set prms = pt.Parameters
    
    Dim ary() As Variant
    ReDim ary(lst.Count - 1)
    
    Dim baseName As String
    Dim txtH As String
    Dim txtV As String
    Dim prmH As Parameter
    Dim prmV As Parameter
    Dim subLst As Parameters
    Dim cnt As Long
    
    cnt = -1
    For i = 1 To lst.Count
        Set subLst = prms.SubList(lst.Item(i), False)
        baseName = subLst.GetNameToUseInRelation(lst.Item(i))
        
        txtH = Left(baseName, Len(baseName) - 1) & _
            "\" & KEY_H & Right(baseName, 1)
        txtV = Left(baseName, Len(baseName) - 1) & _
            "\" & KEY_V & Right(baseName, 1)
        
        Set prmH = GetParameter(txtH, subLst)
        Set prmV = GetParameter(txtV, subLst)
        
        If (Not prmH Is Nothing) And (Not prmV Is Nothing) Then
            ary(i - 1) = Array(lst.Item(i).name, prmH, prmV)
            cnt = cnt + 1
        End If
    Next
    
    If cnt < 0 Then Exit Function '点なし
    
    If Not UBound(ary) = cnt Then
        ReDim Preserve ary(cnt)
    End If
    
    GetParameters = ary
    
End Function

'ﾊﾟﾗﾒｰﾀ取得
Private Function GetParameter( _
    ByVal key As String, _
    ByVal params As Parameters) As Parameter
    
    Set GetParameter = Nothing
    
    Dim prm As Parameter
    Err.Number = 0
    On Error Resume Next
        Set prm = params.Item(key)
    On Error GoTo 0
    
    Set GetParameter = prm
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, _
                                   False, 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

赤印部分は選択した形状ｾｯﾄ名にした方が自然な感じがしたので、
そのように変更してみました。
たった19個ですが0.2秒程。　でも昨日は1分近くかかってました。

高速になった要因です。

InitTable関数のこの辺

　・・・
    '書き出し
    Dim r As Long
    tbl.ComputeMode = CatTableComputeOFF
　・・・
    tbl.ComputeMode = CatTableComputeON
    ・・・

excelのマクロの様に、セルに書き込んでる際に描写を止めました。
でも、効果は少しです。

効果が大きかったのはGetParameters関数のこの辺りです

　・・・
    Dim prmH As Parameter
    Dim prmV As Parameter
    Dim subLst As Parameters
    Dim cnt As Long
    
    cnt = -1
    For i = 1 To lst.Count
        Set subLst = prms.SubList(lst.Item(i), False)'←ここの効果が絶大
        baseName = subLst.GetNameToUseInRelation(lst.Item(i))
        
        txtH = Left(baseName, Len(baseName) - 1) & _
            "\" & KEY_H & Right(baseName, 1)
        txtV = Left(baseName, Len(baseName) - 1) & _
            "\" & KEY_V & Right(baseName, 1)
        
        Set prmH = GetParameter(txtH, subLst)
        Set prmV = GetParameter(txtV, subLst)
　・・・

パラメータを取得している部分です。こちらに詳しく記載されています。
Efficiently navigating parameter collections | CATIA V5 Automation

予め抜き出すオブジェクトがわかっているなら、SubListでパラメータを
抜き出してから探し出した方が速いってことらしいです。確かに。
baseNameを取得してからHやVを抜き出しているけど、直接出来るかも。

但し、こちらの問題が解決しないので、これ自体はボツになりそう。
DrawingTableのSetCellObjectﾒｿｯﾄﾞ機能していない - C#ATIA

DrawingTableのSetCellObjectﾒｿｯﾄﾞ機能していない

このメソッドです。
r1 DrawingTable (Object)

既存のテキストをテーブルのセルに突っ込んでしまいたいのですが、
エラーになります。

こんなコードを作りました。

'vba エラーになります using kcl
Option Explicit

Sub CATMain()
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    Dim vi As DrawingView
    Set vi = dDoc.Sheets.ActiveSheet.views.ActiveView
    
    Dim tbl As DrawingTable
    Set tbl = KCL.SelectItem("ﾃｰﾌﾞﾙ選択", "DrawingTable")
    If tbl Is Nothing Then Exit Sub
    
    Dim dt As DrawingText
    Set dt = KCL.SelectItem("ﾃｷｽﾄ選択", "DrawingText")
    If dt Is Nothing Then Exit Sub
    
    tbl.ComputeMode = CatTableComputeON
    tbl.SetCellObject 1, 1, dt '←ここでエラー

End Sub

こんな感じのテーブルとテキストを用意します。

マクロを実行し、テーブルを選択した後、テキストを選択します。

エラーになります。
型指定を辞めたりイロイロとやったつもりなのですがダメです。

そもそもGetは兎も角Set出来るのかな？　とは思っていましたよ。
手動でも出来ないから。参照先を変えてくれれば良いだけなんだけどなぁ。

もちろんSetCellStringメソッドは成功するのですが、それでは
属性リンクが無い状態なんです。

検索しても成功事例無し。「ダメだ」と言う情報すら無し。
機能しないのならHelpに載せないで欲しい。

2D属性リンクを扱いたい5 属性ﾘﾝｸ付き座標ﾃｰﾌﾞﾙ

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

やっと属性リンク付き座標テーブルが出来ました。

'vba AttributeLinkTable Ver0.0.1 using-'KCL0.0.12'  by Kantoku
'属性リンク付き座標テーブル-平面上の点のみ対応

Private Const TITLE = "AttributeTable"  'ﾃｰﾌﾞﾙのﾀｲﾄﾙ
Private Const KEY_H = "H"               'ﾊﾟﾗﾒｰﾀ用Hｷｰ
Private Const KEY_V = "V"               'ﾊﾟﾗﾒｰﾀ用Vｷｰ
Private Const ROWSIZE = 10              'ﾃｰﾌﾞﾙ初期行高さ
Private Const COLUMNSIZE = 35           'ﾃｰﾌﾞﾙ初期列幅

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    'ﾋﾞｭｰ選択
    Dim msg As String
    msg = "ﾃｰﾌﾞﾙを作成する、ﾋﾞｭｰを選択してください /ESC-終了"
    
    Dim vi As DrawingView
    Set vi = KCL.SelectItem(msg, "DrawingView")
    If vi Is Nothing Then Exit Sub
    
    '形状ｾｯﾄ選択
    msg = "平面上の点を含んだ、形状ｾｯﾄを選択してください /ESC-終了"
    
    Dim hBdy As HybridBody
    Set hBdy = SelectItem4(msg, msg, Array("HybridBody"))
    If hBdy Is Nothing Then Exit Sub
    
    'ﾘﾝｸPart取得
    Dim lnkPt As Part
    Set lnkPt = KCL.GetParent_Of_T(hBdy, "Part")
    If lnkPt Is Nothing Then
        MsgBox "形状ｾｯﾄのPartが取得できませんでした"
        Exit Sub
    End If
    
    'ﾊﾟﾗﾒｰﾀ名取得
    Dim prms As Variant
    prms = GetParamNames(hBdy)
    If IsEmpty(prms) Then
        msg = "処理すべき点が含まれていませんでした" & vbCrLf & _
            "（平面上の点のみ対応してます）"
        MsgBox msg
        Exit Sub
    End If
    
    'ﾃｰﾌﾞﾙ作成
    Dim tbl As DrawingTable
    Set tbl = vi.Tables.Add(0, 0, 1, 1, ROWSIZE, COLUMNSIZE) '仮
    
    'ﾃｰﾌﾞﾙに書き込み
    Call PushData2Table(tbl, prms, lnkPt.Parameters)
    
    MsgBox "done"
    
End Sub

'ﾃｰﾌﾞﾙに投げ込む
Private Sub PushData2Table( _
    ByVal tbl As DrawingTable, _
    ByVal pntprms As Variant, _
    ByVal prms As Parameters)
    
    'Column追加
    Dim clmcnt As Long
    clmcnt = UBound(pntprms(0))
    
    Dim c As Long
    For c = 0 To clmcnt - 1
        Call tbl.AddColumn(1)
    Next
    
    'row追加+ﾀｲﾄﾙ分
    Dim rowcnt As Long
    rowcnt = UBound(pntprms)
    
    Dim r As Long
    For r = 0 To rowcnt
        Call tbl.AddRow(1)
    Next
    
    'タイトル
    Dim titles As Variant
    titles = Array(TITLE, KEY_H, KEY_V)
    
    Dim dt As DrawingText
    For c = 0 To clmcnt
        Set dt = tbl.GetCellObject(1, c + 1)
        dt.Text = titles(c)
    Next
    
    '書き出し
    For r = 0 To rowcnt
        Set dt = tbl.GetCellObject(r + 2, 1)
        dt.Text = pntprms(r)(0)
        
        For c = 1 To clmcnt
            Set dt = tbl.GetCellObject(r + 2, c + 1)
            Call dt.InsertVariable(0, 0, prms.Item(pntprms(r)(c)))
        Next
    Next
    
End Sub

'形状ｾｯﾄ内の点からﾊﾟﾗﾒｰﾀ名を取得
Private Function GetParamNames( _
    ByVal hBdy As HybridBody) As Variant
    
    Dim shps As HybridShapes
    Set shps = hBdy.HybridShapes
    
    'HybridShapePointOnPlaneのみ
    Dim lst As Collection
    Set lst = New Collection
    
    Dim shp As HybridShape
    Dim i As Long
    For i = 1 To shps.Count
        If Not typename(shps.Item(i)) = "HybridShapePointOnPlane" Then
            GoTo continue
        End If
        
        lst.Add shps.Item(i)
continue:
    Next
    
    If lst.Count < 1 Then Exit Function '点なし
    
    
    'HVﾊﾟﾗﾒｰﾀ名を取得
    Dim pt As Part
    Set pt = KCL.GetParent_Of_T(hBdy, "Part")
    
    Dim prms As Parameters
    Set prms = pt.Parameters
    
    Dim ary() As Variant
    ReDim ary(lst.Count - 1)
    
    Dim baseName As String
    Dim prmH As String
    Dim prmV As String
    Dim cnt As Long
    cnt = -1
    For i = 1 To lst.Count
        baseName = prms.GetNameToUseInRelation(lst.Item(i))
        prmH = Left(baseName, Len(baseName) - 1) & _
            "\" & KEY_H & Right(baseName, 1)
        prmV = Left(baseName, Len(baseName) - 1) & _
            "\" & KEY_V & Right(baseName, 1)
        
        If ExistsParam(prmH, prms) And ExistsParam(prmV, prms) Then
            ary(i - 1) = Array(lst.Item(i).name, prmH, prmV)
            cnt = cnt + 1
        End If
    Next
    
    If cnt < 0 Then Exit Function '点なし
    
    If Not UBound(ary) = cnt Then
        ReDim Preserve ary(cnt)
    End If
    
    GetParamNames = ary
    
End Function

'ﾊﾟﾗﾒｰﾀ存在してる?
Private Function ExistsParam( _
    ByVal key As String, _
    ByVal params As Parameters) As Boolean
        
    Dim prm As Parameter
    
    Err.Number = 0
    On Error Resume Next
        Set prm = params.Item(key)
    On Error GoTo 0
    
    ExistsParam = IIf(Err.Number = 0, True, False)

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, _
                                   False, 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

対象は平面上の点のみです。

まず、座標テーブルを作成するDrawと座標を取得するPartを開きます。

Draw側をアクティブにしてマクロをスタート。
・まず、テーブルを作成するビューを選択。
・続いてPart側をアクティブにし、座標を取得する形状セットを選択。
で終わりです。

実行後の状態はこんな感じです。

属性リンクが付いてます！　・・・どれがどのセルか分かんないのですが。
赤印部分は点の名前です。

・単位要らない　：　プロパティのチェックを外すのはマクロでは無理っぽいです。
・自動ﾌｨｯﾄしたい　：　ここもマクロでは無理っぽいです。
　　
・フォントが気に入らない　：　個人的にはSSS4にしたいのですが、客先環境では
　許されないので、デフォルトのままです。（フォント類はマクロでは修正してません）

ここがゴールじゃない上に、もう業務ではチマチマやってしまいました。
（要は間に合わなかった）
属性リンクの確認も未だやりにくいまま。
それ以上に、何でこんなにテーブルって扱いにくいんだろうとも思ってます。

タイミングが良すぎるぐらいなトピが出来ています。
Drawing text with Attribute link in VB6 - DASSAULT: CATIA products - Eng-Tips
みんな属性リンクに困っているんだな、きっと。

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

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

今直ぐにでも使いたく時間かけていられない為、現状の小道具を
生かすことにします。

属性リンクを使用するのは、単なるテキストではなくテーブルなんです。
（更に一歩ハードルが高いんです）

リンク情報は前回のもの単体で取得できるので、付き合わせる為に
DrawingTable内のDrawingTextのオブジェクト名をCSVで吐き出す
マクロを作ります。

'vba using-'KCL0.0.12'  by Kantoku
'DrawTable内のDrawTxtのｵﾌﾞｼﾞｪｸﾄ名と値を書き出す

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    'ｴｸｽﾎﾟｰﾄﾊﾟｽ
    '本当は一度保存しているかﾁｪｯｸすべき
    Dim exppath As String
    exppath = GetExpPath(dDoc.FullName)
    
    'テーブル選択
    Dim msg As String
    msg = "テーブル選択"
    
    Dim dt As DrawingTable
    Set dt = KCL.SelectItem(msg, "DrawingTable")
    If dt Is Nothing Then Exit Sub
    
    'テーブル情報
    Dim data As Variant
    data = GetTableData(dt)
    
    'ｴｸｽﾎﾟｰﾄ
    Call KCL.WriteFile(exppath, Join(data, vbCrLf))
    
    MsgBox "done"
    
End Sub

Private Function GetExpPath( _
    ByVal drwpath As String) As String

    Dim ary As Variant
    ary = KCL.SplitPathName(drwpath)
    
    Dim tmp As String
    tmp = ary(0) & "\" & ary(1) & "_table" & ".csv"
    
    GetExpPath = KCL.GetNewName(tmp)
    
End Function

Private Function GetTableData( _
    ByVal dt As DrawingTable) As Variant
    
    Dim rowcnt As Long
    rowcnt = dt.NumberOfRows
    
    Dim clmcnt As Long
    clmcnt = dt.NumberOfColumns
    
    Dim cells() As String
    ReDim cells(rowcnt - 1)
    Dim tmp() As String
    
    Dim i As Long, j As Long
    Dim drwtxt As DrawingText
    For i = 1 To rowcnt
        ReDim tmp(clmcnt - 1)
        For j = 1 To clmcnt
            Set drwtxt = dt.GetCellObject(i, j)
            tmp(j - 1) = "(" & drwtxt.name & ":" & drwtxt.Text & ")"
        Next
        cells(i - 1) = Join(tmp, ",")
    Next
        
    GetTableData = cells
        
End Function

本来なら行うべき細かなﾁｪｯｸはしてません。

実行するとDrawファイルと同じでフォルダ内に
（Drawﾌｧｲﾙ名）_table.csv
が出来上がります。

吐き出されるデータはCSVフォーマットで各セルの
（オブジェクト名 : セルの値）
なっています。

サポートさんに指摘されたのですが、このセルのオブジェクト名は
手動で確認出来ないんです。
（手動でセルのプロパティを開いても "テーブル.xx" のような表記です）
その為、リンク情報で表示される「元エレメント」の名前で検索しても
Hitしません。

リンク情報見ても役に立たないんですね･･･。

出来上がった2個のCSVを付き合せて確認。人力で。

どう考えても面倒です。確認出来ないよりはまだマシですが、
時間が出来たらまともな物を作成します・・・。

それ以上にリンク情報を取得するヤツが、実務データで試すとエラー
になっちゃうんです。リンクが多いとエラーになるので、恐らく
ダイアログを閉じるタイミングが早過ぎるんだろうと思うのですが。

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

大した進展も無いまま、こちらの続きです。（忘れそうなので）
2D属性リンクを扱いたい2 - C#ATIA

こちらのC#で作ったやつ、正常に動きませんでした･･･。
3D CAD Model Collection | GrabCAD Community Library
何でだろう、と思ったのでVS立ち上げて実行したら動きました。

Attributeも、ちゃんと取得出来てます。

とりあえずビルドしたらexeファイルでも動いたので、少し安心しました。
VS立ち上がる際、何かUpdateしていたのでその辺が原因だったのかも。

但し、VBAと絡めて実行する際ちょっとばかり使い勝手が悪いので
何か対策を取らないと。
3年前なのでVBAのコードもイマイチで、その分自分が成長したんだろう
と思っておきたい。