こちらの続きです。
2D属性リンクを扱いたい4 - C#ATIA
やっと属性リンク付き座標テーブルが出来ました。
Private Const TITLE = "AttributeTable"
Private Const KEY_H = "H"
Private Const KEY_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
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)
Dim clmcnt As Long
clmcnt = UBound(pntprms(0))
Dim c As Long
For c = 0 To clmcnt - 1
Call tbl.AddColumn(1)
Next
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
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
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
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
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
みんな属性リンクに困っているんだな、きっと。
