ビューの位置を保存・再現2

前回不満だった
・マクロ処理後の移動ログ表示ミス
・角度の再現化
を修正しました。

'vba Draw_ViewsPositionLoaderWriter ver0.0.3  using-'KCL0.0.12'  by Kantoku
'
'ver0.0.1:完成
'ver0.0.2:読み書き1本化,未変更時Writer書き込まない
'ver0.0.3:ﾛｸﾞを正しく表記するよう修正,角度も再現化

Option Explicit

'変更しないで!
Private Const VIEWS_POS_HAEDER = "views_pos_"

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'ﾓﾛﾓﾛ
    Dim msg As String
    
    Dim doc As DrawingDocument
    Set doc = CATIA.ActiveDocument
    
    Dim sheet As DrawingSheet
    Set sheet = doc.Sheets.ActiveSheet
    
    'View数ﾁｪｯｸ
    Dim vs As DrawingViews
    Set vs = sheet.Views
    
    If vs.Count < 3 Then
        msg = "処理を行うViewがありません!"
        MsgBox msg, vbOKOnly + vbExclamation
        Exit Sub
    End If

    'ﾊﾟﾗﾒｰﾀｰﾁｪｯｸ
    Dim prm_name As String
    prm_name = VIEWS_POS_HAEDER & sheet.Name
    
    Dim prm As StrParam
    Set prm = GetParam(prm_name)
    
    '選択/処理
    msg = "View位置の保存・再現を行います" & vbCrLf & _
          "再 現 : はい" & vbCrLf & _
          "保 存 : いいえ" & vbCrLf & _
          "中 止 : キャンセル"
    
    If prm Is Nothing Then
        msg = msg & vbCrLf & _
              "※保存データが無いため再現できません!!"
    End If
    
    Select Case MsgBox(msg, vbYesNoCancel)
        Case vbYes
            Call ViewsPositionLoader(prm, vs)
        Case vbNo
            Call ViewsPositionWriter(prm, prm_name, vs)
    End Select
End Sub

' -- Loader --
Private Sub ViewsPositionLoader(ByVal prm As StrParam, _
                                ByVal vs As DrawingViews)
    Dim msg As String
    
    If prm Is Nothing Then
        msg = "保存されたView位置がありませんでした"
        MsgBox msg, vbOKOnly + vbInformation
        Exit Sub
    End If
    
    '読み出しのﾋﾞｭｰ情報取得
    Dim load_infos As Object
    Set load_infos = LoadInfos_Dic(prm.Value)
    
    '現状のﾋﾞｭｰ情報取得
    Dim unreg As String
    unreg = GetUnregisteredViews(vs, load_infos)
    
    '確認
    msg = "View位置を再現しますか?"
    If Not unreg = vbNullString Then
        msg = "以下のViewの位置が記録されていませんでした" & vbCrLf & _
              unreg & msg
    End If
    
    If MsgBox(msg, vbYesNo + vbQuestion) = vbNo Then
        Exit Sub
    End If
    
    '実行
    msg = ExecMoveViews(vs, load_infos)
    
    MsgBox "Done" & vbCrLf & msg
End Sub

Private Function ExecMoveViews(ByVal vs As DrawingViews, _
                               ByVal dic As Object) As String

    '実行前位置
    Dim before_pos As Variant
    before_pos = GetViewsInfo(vs)
    
    '移動実行
    Dim key As Variant ' String
    Dim v As DrawingView
    Dim xy As Variant
    
    For Each key In dic
        Set v = GetView(vs, key)
        If v Is Nothing Then GoTo continue
        
        xy = dic(key)
        If Not KCL.IsAryEqual( _
                Array(CStr(v.xAxisData), CStr(v.yAxisData), CStr(v.angle)), _
                xy) Then
            v.xAxisData = CDbl(xy(0))
            v.yAxisData = CDbl(xy(1))
            v.angle = CDbl(xy(2))
        End If
continue:
    Next
    
    '結果
    Dim msg As String
    Dim info As Variant
    Dim i As Long
    
    For i = 0 To UBound(before_pos)
        info = Split(before_pos(i), ",")
        
        Set v = GetView(vs, info(0))
        msg = msg & v.Name & " : 移動"
        
        If Not dic.Exists(info(0)) Then
            msg = msg & "していません" & vbCrLf
            GoTo continue_res
        End If
        
        xy = dic(info(0))
        If Not KCL.IsAryEqual(Array(CStr(info(1)), CStr(info(2)), CStr(info(3))), xy) Then
            msg = msg & "しました!" & vbCrLf
        Else
            msg = msg & "していません" & vbCrLf
        End If
continue_res:
    Next
    
    ExecMoveViews = msg
End Function

Private Function GetView(ByVal vs As DrawingViews, _
                         ByVal s As String) As DrawingView
    On Error Resume Next
        Set GetView = vs.GetItem(s)
    On Error GoTo 0
End Function

Private Function GetUnregisteredViews(ByVal vs As DrawingViews, _
                                      ByVal dic As Object) As String
    Dim msg As String
    
    Dim i As Long
    Dim v As DrawingView
    
    For i = 0 To vs.Count - 3
        Set v = vs.Item(i + 3)
        If Not dic.Exists(KCL.GetInternalName(v)) Then
            msg = msg & v.Name & vbCrLf
        End If
    Next
    
    GetUnregisteredViews = msg
End Function

Private Function LoadInfos_Dic(ByVal data As String) As Object
    Dim dic As Object
    Set dic = KCL.InitDic()
    
    Dim infos As Variant
    infos = Split(data, "@")
    
    Dim i As Long
    Dim info_ary As Variant
    For i = 0 To UBound(infos)
        info_ary = Split(infos(i), ",")
        If UBound(info_ary) < 4 Then
            dic.Add info_ary(0), Array(info_ary(1), info_ary(2), "0")
        Else
            dic.Add info_ary(0), Array(info_ary(1), info_ary(2), info_ary(3))
        End If
    Next
    
    Set LoadInfos_Dic = dic
End Function

' -- Writer --
Private Sub ViewsPositionWriter(ByVal prm As StrParam, _
                                ByVal prm_name As String, _
                                ByVal vs As DrawingViews)
    Dim msg As String
    
    If prm Is Nothing Then
        Set prm = InitParam(prm_name)
    Else
        msg = "過去にView位置を保存しています" & vbCrLf & _
              "上書きしますか?"
        If MsgBox(msg, vbYesNo + vbQuestion) = vbNo Then
            Exit Sub
        End If
    End If
    
    'ﾋﾞｭｰ情報取得
    Dim infos As String
    infos = CStr(Join(GetViewsInfo(vs), "@"))
    
    'ﾊﾟﾗﾒｰﾀ書き込み
    prm.Value = infos
    
    MsgBox "Done"
End Sub

Private Function GetViewInfo(ByVal v As DrawingView) As String
    GetViewInfo = CStr(Join(Array( _
                    KCL.GetInternalName(v), _
                    v.xAxisData, _
                    v.yAxisData, _
                    v.angle _
                    ), ","))
End Function

Private Function GetViewsInfo(ByVal vs As DrawingViews) As Variant
    Dim infos() As String
    ReDim infos(vs.Count - 3)
    
    Dim i As Long
    For i = 0 To UBound(infos)
        infos(i) = GetViewInfo(vs.Item(i + 3))
    Next
    
    GetViewsInfo = infos
End Function

Private Function InitParam(ByVal s As String) As StrParam
    Dim prms As Parameters
    Set prms = GetParams()
    
    Dim prm As StrParam
    Set prm = prms.CreateString(s, "")
    
    Set InitParam = prm
End Function

' -- Common --
Private Function GetParam(ByVal s As String) As StrParam
    Dim prms As Parameters
    Set prms = GetParams()
    
    Dim prm As StrParam
    
    On Error Resume Next
        Set prm = prms.Item(s)
    On Error GoTo 0
    
    Set GetParam = prm
End Function

Private Function GetParams() As Parameters
    Dim doc As DrawingDocument
    Set doc = CATIA.ActiveDocument
    
    Set GetParams = doc.Parameters.RootParameterSet.DirectParameters
End Function

パラメータに保存する形式が以下の様に変わりました。

ビューインターナルネーム,X座標,Y座標,角度@ビューインターナルネーム,X座標,Y座標,角度@・・・

要は角度も保存するようにしました　と言うことです。
Ver0.0.2以前のものは強制的に0度にしてしまいます。
（面倒だった為･･･）

C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

ビューの位置を保存・再現2