全ての寸法に番号バルーンを付ける3

こちらの続きです。
全ての寸法に番号バルーンを付ける2 - C#ATIA
時間がかかりましたね・・・。

前回の物を実行するとこんな感じです。

確かに寸法上にバルーンが配置されています。
しかし、バルーンのテキスト部分が、全て同じような右上方向ですよね？
ここがイマイチなんです。

そこで、もうちょっとそれっぽい位置に配置されるように考えました。

'vba using-'KCL0.1.0'  by Kantoku
'アクティブなシートの全寸法に番号バルーンを付ける

'バルーンレポートビュー名
Private Const BALLOON_VIEW_NAME = "BALLOON"

'テンプレートバルーン名
Private Const TEMPLATE_SHEET_NAME = "template"
Private Const TEMPLATE_BALLOON_NAME = "balloon"

'true/false　vbaとCATIA API食い違い代案
Private Enum BOOL
    boolFalse = 0
    boolTrue = 1
End Enum

'関連テキスト用
Private Enum Dimension_Value
    Main_Value = 1
    Dual_Value = 2
End Enum

Option Explicit


Sub CATMain()

    '除外する関連テキストフィルター
    'Before, After, Upper, Lower
    Dim blackList As Variant
    blackList = Array( _
        Array("(", ")", "", "") _
    )

    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument

    Dim sheet As DrawingSheet
    Set sheet = dDoc.sheets.ActiveSheet

    KCL.SW_Start

    'バルーンテンプレート
    Dim balloonInfo As Variant
    balloonInfo = get_template_balloon()
    If UBound(balloonInfo) < 2 Then
        Exit Sub
    End If

    'コピー
    copy_entity balloonInfo
    sheet.Activate
    
    Dim balloonView As DrawingView
    Set balloonView = get_view_by_name( _
        BALLOON_VIEW_NAME)

    Dim drawDims As Variant
    Dim view As DrawingView
    Dim i As Long
    Dim balloon As DrawingText

    Dim balloonIdx As Long 'ナンバリング用インデックス
    balloonIdx = 1

    Dim dimBBox As BBox2D
    Dim viewBBox As BBox2D
    Dim viewVec As Vec2D
    Dim textVec As Vec2D
    Dim textPnt As Pnt2D

    CATIA.HSOSynchronized = True

    For Each view In sheet.views
        '寸法検索
        drawDims = get_dimensions_by_view(view, blackList)
        If UBound(drawDims) < 1 Then
            GoTo continue
        End If

        'ビューバウンダリボックス
        Set viewBBox = GeoFactry.create_boundary_box_by_view( _
            view _
        )
        Set viewVec = viewBBox.origin_point().as_vector()
        
        For i = 0 To UBound(drawDims)
            '寸法バウンダリボックス
            Set dimBBox = GeoFactry.create_boundary_box_by_dimension( _
                drawDims(i) _
            )
            dimBBox.translate_by viewVec

            'バルーンのペースト
            Set balloon = pre_copide_and_paste(balloonView)

            'テキスト位置算出
            Set textPnt = dimBBox.center_point.clone()
            Set textVec = viewBBox.center_point.vector_to(textPnt)
            textVec.normalize
            textVec.scale_by 20
            textPnt.translate_by textVec

            'バルーン位置調整
            move_balloon _
                balloon, _
                textPnt, _
                dimBBox.center_point

            'バルーンテキスト修正
            balloon.Text = CStr(balloonIdx)

            'カウンタ更新
            balloonIdx = balloonIdx + 1
        Next

        CATIA.RefreshDisplay = True

continue:
    Next

    CATIA.HSOSynchronized = False

    MsgBox "Done : " & KCL.SW_GetTime

End Sub


'検索し配列で取得
Private Function get_search_items( _
    ByVal searchWord As String, _
    Optional selectEntity = Nothing) _
    As Variant

    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    Dim sel As Selection
    Set sel = dDoc.Selection

    sel.Clear
    If Not selectEntity Is Nothing Then
        sel.add selectEntity
    End If
    
    sel.Search searchWord
    
    If sel.Count2 < 1 Then
        get_search_items = Array()
        Exit Function
    End If
    
    Dim drawDims() As Variant
    ReDim drawDims(sel.Count2 - 1)
    
    Dim i As Long
    For i = 1 To sel.Count2
        Set drawDims(i - 1) = sel.Item(i).value
    Next
    
    sel.Clear
    
    get_search_items = drawDims

End Function


'ビュー内の寸法取得-フィルター付き
Private Function get_dimensions_by_view( _
    ByVal view As DrawingView, _
    ByVal filterBlack As Variant) _
    As Variant

    Dim dims As Variant
    dims = get_search_items( _
        "CATDrwSearch.DrwDimension,sel", _
        view _
    )
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim i As Long
    For i = 0 To UBound(dims)
        If Not is_match_bault_text(dims(i), filterBlack) Then
            lst.add dims(i)
        End If
    Next

    get_dimensions_by_view = collection_to_array_by_obj(lst)

End Function


'関連テキストのメイン値でフィルターと一致するか？
Private Function is_match_bault_text( _
    ByVal drawDim As DrawingDimension, _
    ByVal filterList As Variant) _
    As Boolean
    
    Dim dimValue As Variant 'DrawingDimValue
    Set dimValue = drawDim.GetValue()

    Dim before, after, upper, lower
    dimValue.GetBaultText _
        Dimension_Value.Main_Value, _
        before, _
        after, _
        upper, _
        lower

    Dim stateBaultText As String
    stateBaultText = Join( _
        Array(before, after, upper, lower), _
        "@" _
    )

    Dim i As Long
    Dim filter As String
    For i = 0 To UBound(filterList)
        filter = Join( _
            filterList(i), _
            "@" _
        )
        If stateBaultText = filter Then
            is_match_bault_text = True
            Exit Function
        End If
    Next

    is_match_bault_text = False

End Function


'ビューを名前で取得
'Optional isCreate - true:なきゃ作る false:なきゃnothing
Private Function get_view_by_name( _
    ByVal name As String, _
    Optional isCreate = True) _
    As DrawingView
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument

    Dim views As DrawingViews
    Set views = dDoc.sheets.ActiveSheet.views

    Dim view As DrawingView
    For Each view In views
        If Not view.name = name Then
            GoTo continue
        End If
        
        Set get_view_by_name = view
        Exit Function
        
continue:
    Next

    If isCreate Then
        Set get_view_by_name = views.add(name)
    Else
        Set get_view_by_name = Nothing
    End If
    
End Function


'シートを名前で取得
Private Function get_sheet_by_name( _
    ByVal name As String, _
    Optional isDetail As Integer) _
    As DrawingSheet
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument

    Dim sheets As DrawingSheets
    Set sheets = dDoc.sheets

    Dim sheet As DrawingSheet
    For Each sheet In sheets
        If Not sheet.name = name Then
            GoTo continue
        End If

        If sheet.isDetail <> isDetail Then
            GoTo continue
        End If

        Set get_sheet_by_name = sheet
        Exit Function
        
continue:
    Next

    Set get_sheet_by_name = Nothing
    
End Function


'テンプレートバルーンの取得
'return array(DrawingSheet, DrawingView, drawingtext)
Private Function get_template_balloon() _
    As Variant

    get_template_balloon = Array()
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument

    Dim backupSheet As DrawingSheet
    Set backupSheet = dDoc.sheets.ActiveSheet.views

    Dim sheet As DrawingSheet
    Set sheet = get_sheet_by_name(TEMPLATE_SHEET_NAME, BOOL.boolTrue)
    If sheet Is Nothing Then
        MsgBox "テンプレートディテールシートがありません"
        Exit Function
    End If
    sheet.Activate
    
    Dim view As DrawingView
    Set view = get_view_by_name(TEMPLATE_BALLOON_NAME)
    If view Is Nothing Then
        MsgBox "テンプレートビューがありません"
        backupSheet.Activate
        Exit Function
    End If

    view.Activate
    Dim items As Variant
    items = get_search_items( _
        "CATDrwSearch.DrwBalloon,sel", _
        view _
    )
    
    If UBound(items) < 0 Then
        MsgBox "テンプレートバルーンがありません"
        backupSheet.Activate
        Exit Function
    End If

    '最初にHitしたバルーン
    get_template_balloon = Array(sheet, view, items(0))

    backupSheet.Activate

End Function


'コピー済みの状態からペースト
Private Function pre_copide_and_paste( _
    ByVal targetView As DrawingView) _
    As DrawingText
    
    Dim targetSheet As DrawingSheet
    Set targetSheet = KCL.GetParent_Of_T(targetView, "DrawingSheet")

    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument

    Dim sel As Selection
    Set sel = dDoc.Selection

    targetSheet.Activate
    
    sel.add targetView
    sel.Paste
    
    Set pre_copide_and_paste = sel.Item2(1).value
    sel.Clear

End Function


'バルーン情報から要素をコピーのみ
Private Sub copy_entity( _
    ByVal balloonInfo As Variant)
    
    Dim sheet As DrawingSheet
    Set sheet = balloonInfo(0)

    Dim view As DrawingView
    Set view = balloonInfo(1)
    
    Dim balloon As DrawingText
    Set balloon = balloonInfo(2)
    
    Dim dDoc As DrawingDocument
    Set dDoc = CATIA.ActiveDocument
    
    Dim sel As Selection
    Set sel = dDoc.Selection

    sel.Clear
    sheet.Activate
    view.Activate
    sel.add balloon
    sel.Copy
    sel.Clear

End Sub


'バルーンの移動
Private Sub move_balloon( _
    ByVal balloon As DrawingText, _
    textPnt As Pnt2D, _
    leaderPnt As Pnt2D)

    Dim drawLeader As DrawingLeader
    Set drawLeader = balloon.leaders.Item(1)

    balloon.x = textPnt.x
    balloon.y = textPnt.y
    
    drawLeader.ModifyPoint 1, leaderPnt.x, leaderPnt.y

End Sub


'オブジェクトコレクション->配列
Private Function collection_to_array_by_obj( _
    lst As Collection) _
    As Variant

    If lst.count < 1 Then
        collection_to_array_by_obj = Array()
        Exit Function
    End If

    Dim ary() As Variant
    ReDim ary(lst.count - 1)

    Dim i As Long
    For i = 1 To lst.count
        Set ary(i - 1) = lst(i)
    Next

    collection_to_array_by_obj = ary

End Function

"KCL" についてはこちら
GitHub - kantoku-code/KCL: CATIA Library for personal CATVBA (CATIA macro)

"BBox2D" "GeoFactry" "Pnt2D" "Vec2D" についてはこちら
GitHub - kantoku-code/CATIA_V5_Geometry_used_for_balloon_adjustment: これは将来削除します

が同じプロジェクト内に必要です。

バルーンテキストの配置位置は、この様に考えました。

ビューの中心から寸法の中心位置への方向を求め、寸法中心位置から
その方向に少しずらした位置にバルーンテキストを配置する事に
しました。
実際に実行した結果はこの様な感じです。

前回の物に比べそれっぽい状態になりました。
とは言え、手動で位置調整は必要になると思いますが。