表題欄の細々した項目をパラメータで変更する1

CATIAの図面枠って、通常は背景図で作ってますよね？
僕もそうなんですけど。

図面枠だけじゃなくて表題欄も背景図に入ってますよね？
最初からCATIAで図面を書いていたのであれば、表題欄はテーブルで
上手に作るのが正攻法のような気がするのですが、
他の2DCADから移行したので、極端にレイアウトを変更する訳には
行かなかったりするわけです。

結果的に、以前の2DCADから図面枠をDXFでエクスポートして
CATIAにインポートしてゴニョゴニョして作ってしまう企業様も
多いはずです。　・・・よね？

僕のはこんな感じです。記載すべき内容はそれぞれの枠に見立てた
線と線の間にテキストを配置して、そこに書き込みます。
（テーブルだと各セルに書きますが、DXFからインポートして作っているので
　セルじゃなくテキストなんです　って事です。）

ちょっとした操作ミスで書き換える事が出来ないから、背景図にしている
のだろうと思うのですが、書き換える必要がある時は結構手間じゃないで
しょうか?　・・・要は　”頻繁じゃないけど面倒”　なんです。

そこで、パラメータと連動して表題欄が書き換わったら素敵なんじゃないかな？
って思い付いたんです。

そこで、マクロを作りました。

'vba Draw_TableTitleAttrLink Ver0.0.1 by Kantoku
Option Explicit

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ をしたかったらKCL使ってね
'    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'ドキュメント
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    'パラメータ
    Dim prms As Parameters
    Set prms = dDoc.Parameters.RootParameterSet.AllParameters
    If prms.Count < 1 Then
        MsgBox "パラメータがありませんでした"
        Exit Sub
    End If
    
    'テキストコレクション
    Dim txts As DrawingTexts
    Set txts = getBackViewTexts(dDoc)
    If txts.Count < 1 Then
        MsgBox "背景図に文字がありませんでした"
        Exit Sub
    End If
    
    'ペア
    Dim txt_prm_Lst As Collection
    Set txt_prm_Lst = findPair(txts, prms)
    If txt_prm_Lst.Count < 1 Then
        MsgBox "パラメータと同一名の文字がありませんでした"
        Exit Sub
    End If
    
    '問い合わせ
    If Not query(txt_prm_Lst) Then
        Exit Sub
    End If
    
    '属性適用
    Call setParameter(txt_prm_Lst)

End Sub

'属性適用
'prm:txt_prm_Lst(collection:DrawingText,Parameter)
Private Sub setParameter( _
    ByVal txt_prm_Lst As Collection)

    Dim pair As Collection
    Dim txt As DrawingText
    Dim prm As Parameter
    For Each pair In txt_prm_Lst
        Set txt = pair.Item(1)
        Set prm = pair.Item(2)
        
        txt.Text = vbNullString
        Call txt.InsertVariable(0, 0, prm)
    Next

End Sub

'問い合わせ
Private Function query( _
    ByVal txt_prm_Lst As Collection) _
    As Boolean

    query = False
    
    Dim names As String
    names = getNames(txt_prm_Lst)
    
    Dim msg As String
    msg = txt_prm_Lst.Count & "個のパラメータを適用出来ます。" & vbCrLf & _
        "実行しますか？" & vbCrLf & vbCrLf
    
    If MsgBox(msg & names, vbYesNo + vbQuestion, "属性適用") = vbYes Then
        query = True
    End If
    
End Function

'テキスト名取得
Private Function getNames( _
    ByVal txt_prm_Lst As Collection) _
    As String

    Dim ary() As String
    ReDim ary(txt_prm_Lst.Count - 1)

    Dim i As Long
    Dim txt As DrawingText
    For i = 1 To txt_prm_Lst.Count
        Set txt = txt_prm_Lst.Item(i).Item(1)
        ary(i - 1) = txt.name
    Next
    
    getNames = Join(ary, vbCrLf)
    
End Function
    

'パラメータ名を元に同一名のテキストとのペアリスト取得
Private Function findPair( _
    ByVal txts As DrawingTexts, _
    ByVal prms As Parameters) _
    As Collection

    Dim lst As Collection
    Set lst = New Collection

    Dim prm As Parameter
    Dim txt As DrawingText
    Dim txt_prm As Collection
    
    For Each prm In prms
        Set txt = getTxtByName(txts, prm.name)
        If Not txt Is Nothing Then
            Set txt_prm = New Collection
            txt_prm.Add txt
            txt_prm.Add prm
            lst.Add txt_prm
        End If
    Next
    
    Set findPair = lst
    
End Function

'指定名のテキスト取得
Private Function getTxtByName( _
    ByVal txts As DrawingTexts, _
    ByVal name As String) _
    As DrawingText
    
    Set getTxtByName = Nothing

    Dim txt As DrawingText

    For Each txt In txts
        If txt.name = name Then
            Set getTxtByName = txt
            Exit For
        End If
    Next
    
End Function

'背景図のテキストコレクション取得
Private Function getBackViewTexts( _
    ByVal doc As DrawingDocument) _
    As DrawingTexts
    
    Dim backView As DrawingView
    Set backView = doc.sheets.ActiveSheet.views.Item(2)

    Set getBackViewTexts = backView.Texts

End Function

このマクロを実行すると、

パラメータ名と同じフューチャー名のテキストを背面図から探し出して、
見付かったらパラメータとの属性リンクを作ります。
これで連動します。楽。
・背面図に入って、出ての操作が無くなる
・パラメータの変更はダブルクリックが必要だけど、簡単すぎなくて良い
・ "もう絶対にこの項目は変更しない!" と思った場合、パラメータを削除する
　だけで連動しなくなる（書き変わらなくなる）
・図面サイズを変更する際、図面枠を変更しても表題欄を保てる
・2枚組以上の図面を1ファイルで管理している場合、パラメータ1か所の
　変更で全て行える（個人的には4枚組とかある）
・外部ファイル等(Excel・Csv・Json)で行わないのでCATDrawingファイル
　のみの管理で完結する
と思っていたのですが、ディテールシートにテーブル作り、そこと
連動する属性リンクを作った方が、ダブルクリックの手間が省けて
良いような気もしてきたな・・・。

うちのブログの内容はクズばかりだけど、属性リンクについてだけは
他にも殆ど情報が無いので充実しているかも。（検索するとソコソコＨｉｔ）