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