図面に斜線を追記する

タイトル異なるのですが、こちらの続きです。
Factory2Dが許してくれない2 (許してもらいました) - C#ATIA

加工のお仕事を行う際、現場でちょっとした図面が必要なのですが、
類似品だと1から図面を書くのが面倒です。
その為、リンクの差し替え等で済ませているのですが、複数の部品を
一つのDrawファイルで済ませてます。・・・恐らくマナー違反ですよね？

どうせ見るのは、ほぼ自分のみが見るだけなので、許してください。

その際、全てをいっぺんにリンクの差し替えする訳では無く、
ツールパスの計算をさせながら、次の部品を・・・のような状態の為、
どの図面のリンクを直して、どれを直してないのか分からなくなっちゃいます。

その為、最初に全てのシートに斜線を入れてから作業をはじめ、
差し替え終わったら斜線を消すようにしてます。
・・・デジタルのようでアナログな作業です。

さすがに "最初に全てのシートに斜線を入れて" の作業が面倒な為、
マクロを作ってみました。

'vba Draw_AddStrikethrough ver0.0.1  using-'KCL0.0.12'  by Kantoku
'図面に取り消し線を追加する

'取り消し線名
Private Const STRIKE = "STRIKETHROUGH"

'vba
Option Explicit

'*************
Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not KCL.CanExecute("DrawingDocument") Then Exit Sub

    Dim doc As DrawingDocument
    Set doc = CATIA.ActiveDocument
    
    'get target sheets
    Dim sheets As Collection
    Set sheets = getUnDetailSheets(doc)
    
    If sheets.Count < 1 Then
        MsgBox "対象となるシートがありませんでした"
        Exit Sub
    End If
    
    'Query
    Dim msg As String
    msg = "以下のシートに取り消し線を追記します。宜しいですか？" + _
        vbCrLf + getSheetNames(sheets)
    If MsgBox(msg, vbOKCancel + vbQuestion) = vbCancel Then
        Exit Sub
    End If

    'exec
    Dim stateSheet As DrawingSheet
    Set stateSheet = doc.sheets.ActiveSheet
    
    Call addStrikethrough(sheets)

    stateSheet.Activate

End Sub

Private Sub addStrikethrough( _
    ByVal sheets As Collection)

    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    sel.Clear

    Dim area As Variant
    Dim sheet As DrawingSheet
    Dim views As DrawingViews
    Dim stateView As DrawingView
    For Each sheet In sheets
        sheet.Activate
        Set stateView = sheet.views.ActiveView
        
        Set views = sheet.views
        area = getViewsArea(views)
        
        Call drawLine(views.Item(1), area)
        
        stateView.Activate
    Next
    
End Sub

Private Function drawLine( _
    ByVal view As DrawingView, _
    ByVal area As Variant)
    
    'ロックは強制的に解除
    If view.LockStatus Then
        view.LockStatus = False
    End If

    view.Activate

    Dim fact As Factory2D
    Set fact = view.Factory2D

    Dim line As Line2D
    Set line = fact.CreateLine(area(0), area(2), area(1), area(3))
    line.Name = STRIKE
    
End Function

'return array(0-xmin,1-xmax,2-ymin,3-ymax)
Private Function getViewsArea( _
    ByVal views As DrawingViews) As Variant
    
    Dim area As Variant
    area = Array(100000000, -100000000, 100000000, -100000000)
    
    Dim vi As DrawingView
    Dim viArea As Variant
    For Each vi In views
        viArea = getViewArea(vi, 1.5)
        area = updateArea(area, viArea)
    Next
    
    getViewsArea = area
    
End Function

'return array(0-xmin,1-xmax,2-ymin,3-ymax)
Private Function updateArea( _
    ByVal aryA As Variant, _
    ByVal aryB As Variant) As Variant

    aryA(0) = IIf(aryA(0) < aryB(0), aryA(0), aryB(0))
    aryA(1) = IIf(aryA(1) > aryB(1), aryA(1), aryB(1))
    aryA(2) = IIf(aryA(2) < aryB(2), aryA(2), aryB(2))
    aryA(3) = IIf(aryA(3) > aryB(3), aryA(3), aryB(3))

    updateArea = aryA

End Function

'return array(0-xmin,1-xmax,2-ymin,3-ymax)
Private Function getViewArea( _
    ByVal view As DrawingView, _
    Optional scl As Double) As Variant
    
    Dim x As Double
    x = view.x
    
    Dim y As Double
    y = view.y
    
    Dim variVi As Variant
    Set variVi = view
    
    Dim xy(4) As Variant 'Double
    Call variVi.Size(xy)

    xy(0) = (xy(0) + x) * scl
    xy(1) = (xy(1) + x) * scl
    xy(2) = (xy(2) + y) * scl
    xy(3) = (xy(3) + y) * scl
    
    getViewArea = xy

End Function

Private Function getSheetNames( _
    ByVal sheets As Collection) As String
    
    Dim ary() As String
    ReDim ary(sheets.Count - 1)
    
    Dim i As Long
    For i = 1 To sheets.Count
        ary(i - 1) = sheets(i).Name
    Next
    
    getSheetNames = Join(ary, vbCrLf)

End Function

'ターゲットのシート取得
' ターゲットの条件
'・ディテールシート以外
'・Views.Countが3以上
'・Views.item(3)がロックされていない
'・既に取り消しラインが作成されていない <-Views.item(1)だけ
Private Function getUnDetailSheets( _
    ByVal doc As DrawingDocument) As Collection
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim sheet As DrawingSheet
    For Each sheet In doc.sheets
        If sheet.IsDetail Then GoTo Continue
        If sheet.views.Count < 3 Then GoTo Continue
        If sheet.views.Item(3).LockStatus Then GoTo Continue
        If hasStrikethrough(sheet.views) Then GoTo Continue
        
        lst.Add sheet
        
Continue:
    Next

    Set getUnDetailSheets = lst

End Function

Private Function hasStrikethrough( _
    ByVal views As DrawingViews) As Boolean
    
    Dim view As DrawingView
    Dim drawEnt As AnyObject
    Set view = views.Item(1)
    For Each drawEnt In view.GeometricElements
        If drawEnt.Name = STRIKE Then
            hasStrikethrough = True
            Exit Function
        End If
    Next

    hasStrikethrough = False
    
End Function

シートに斜線を入れる入れないの判断基準はこの様にしています。
・ディテールシート以外　：　ディテールはプロットしないので
・Views.Countが3以上　：　空のシートは斜線が要らない
・Views.item(3)がロックされていない　：　ロックされたシートは既に確定している
・既に取り消しラインが作成されていない　：　線が何重にもひかれるのが邪魔

線の長さが狙っているサイズではないのが謎です(アクティブなビューの影響かもしれない)が、
他人に見せるものでもないし、早く使いたかったしで完成です。