C#ATIA

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

Drawﾋﾞｭｰの原点を変更する1

CATIA_V5 VBA KCL

3Dを元に2Dを作成する際、単に平面を指定すると3Dの原点が
2Dの各ビューの原点になりますが、任意の座標系を2Dの原点としたい場合
座標系を選択した上で平面を指定すればOKですよね？
（言葉では表現しにくいですね）

こんな3Dデータだとします。
f:id:kandennti:20190305120004p:plain
オレンジ色が製品原点で、黄色が部品原点だとします。
実はオレンジ色は絶対座標系です。

2Dを作成する際、何も考えずに平面だけを指定して作業を始めました。
f:id:kandennti:20190305120014p:plain
すいません、適当で･･･。この場合は、最初のオレンジ色（絶対座標系）
の位置が各ビューの原点になっています
f:id:kandennti:20190305120024p:plain
ところが、「お前、何やっているんだ？部品原点を基準に寸法入れるに
決まっているだろ！」と言う事になった場合、どうするのでしょうか？

こちらに「投影平面を修正」コマンドがあるのですが、これはビューの
向きを修正してくれるのですが、原点は変更してくれないですよね？
f:id:kandennti:20190305120033p:plain
探しても探しても原点を修正するコマンドが見つからず、サポートさんに
問い合わせても機能が無いと判りました。（その節はお世話になりました）

代案としては、部品原点の位置に点や線を何らかの方法で作成し、
そこを元に寸法を入れ直し･･･となるのかな？と感じてます。
手間ですね。苦労が水の泡です。

少し前に気になった、こちらのメソッドを利用するとビューの原点位置を
変更出来るのではないかな？　と感じていました。
r1 DrawingViewGenerativeBehavior (Object)
試した所、原点の変更可能がでした。

これを利用して、2Dの原点修正マクロを作成しました。

'vba Draw_ChangeOrigin ver0.0.1  by Kantoku
'using-'KCL0.0.13'

'ﾋﾞｭｰの原点を変更します

'指定出来るﾋﾞｭｰは、基準ﾋﾞｭｰとｱｲｿﾒのみでﾛｯｸされていないもの。
'影響を受けるﾋﾞｭｰは強制的にｱﾝﾛｯｸします。
'変更後に指定出来る座標系は、ﾘﾝｸ元のﾌｧｲﾙに限定しています。
'3Dから生成したﾗｲﾝ・ﾃｷｽﾄ等は移動されませんが
'2Dｺﾝﾎﾟｰﾈﾝﾄ・2D上で描いたﾗｲﾝ等が移動します。

'アイソメ図は関連した図として扱わない
'分離図は対象外
'CGRのみのビューはエラーになる可能性あり
'図の生成ﾓｰﾄﾞがCGRの場合、エラーの可能性あり

Option Explicit

Sub CATMain()

    Dim msg As String

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'DrawDoc
    Dim actDoc As DrawingDocument
    Set actDoc = CATIA.ActiveDocument
    
    '保存確認
    If actDoc.Saved = False Then
        msg = "ﾌｧｲﾙが変更されています!" & vbCrLf & _
            "一度保存後にﾏｸﾛの実行をお勧めしますが、" & vbCrLf & _
            "このままﾏｸﾛを実行しますか?"
        If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    
    'ﾋﾞｭｰ選択
    msg = "投影原点を変更するﾋﾞｭｰを選択 / ESC-ｷｬﾝｾﾙ" & vbCrLf & _
        "(ﾘﾝｸを持ったﾛｯｸされていない基準ﾋﾞｭ-のみ)"
    
    Dim vi As DrawingView
    Set vi = SelectView(msg)
    If vi Is Nothing Then Exit Sub

    
    '参照Doc-分離エラ－
    Dim refDoc As Document
    Set refDoc = GetDocument( _
        vi.GenerativeLinks.FirstLink())
    
    'assy対策
    Dim refDocs As Collection
    Set refDocs = New Collection
    
    Set refDocs = GetChildDocList(refDoc, refDocs)
    
    '参照Docが開かれているか?
    If Not IsOpenDoc(refDoc) Then
        msg = refDoc.Name & vbCrLf & _
            "が開かれていません!" & vbCrLf & _
            "開いてから再度実行してください"
        MsgBox msg, vbExclamation
        Exit Sub
    End If
    
    '選択ﾋﾞｭｰ座標系取得
    Dim BeforeAx As AxisSystem
    Set BeforeAx = GetRefAxis(vi, refDoc.Product)
    
    '選択ﾋﾞｭｰを参照しているﾋﾞｭｰ取得
    Dim vis As Collection
    Set vis = GetReferringViewList(vi)
    
    '座標系選択
    msg = "新しい座標系を" & vbCrLf & _
        refDoc.Name & vbCrLf & _
        "から選択してください" & vbCrLf & _
        "(ESC-ｷｬﾝｾﾙ)"
    MsgBox msg
    
    Dim AfterAx As AxisSystem
    Set AfterAx = SelectAxis(msg, BeforeAx, refDocs)
    If AfterAx Is Nothing Then Exit Sub
    
    '確認
    msg = CreateMsg(vi, vis, BeforeAx, AfterAx)
    If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then
        actDoc.selection.Clear
        Exit Sub
    End If
    actDoc.selection.Clear
    
    'Behavior取得
    Dim behavs As Collection
    Set behavs = GetGenBehaviorList(vis)
    
    '変更
    CATIA.RefreshDisplay = False
    Call ChangeAxis(behavs, AfterAx, refDoc.Product)
    CATIA.RefreshDisplay = True
    
    MsgBox "done"
    
End Sub

'Assy時の子Docの取得
Private Function GetChildDocList( _
    ByVal doc As Document, _
    ByVal lst As Collection) _
    As Collection
    
    If Not typename(doc) = "ProductDocument" Then
        lst.Add doc
        Set GetChildDocList = lst
    End If
    
    Dim pros As Products
    Set pros = doc.Product.Products
    
    Dim pro As Product
    Dim childDoc As Document
    For Each pro In pros
        Set childDoc = pro.ReferenceProduct.Parent 'doc
        'cgrはここでProductDocumentを返している
        If childDoc Is Nothing Then GoTo continue
        
        If typename(childDoc) = "ProductDocument" Then
            If Not IsEqDoc(childDoc, doc) Then
                 Set lst = GetChildDocList(childDoc, lst)
            End If
        Else
            lst.Add childDoc
        End If
continue:
    Next
    
    Set GetChildDocList = lst
    
End Function

'ﾊﾟﾗﾒｰﾀで戻り値をCATSafeArrayVariantで受け取るﾀｲﾌﾟに効果絶大
Private Function AsDisp( _
    o As INFITF.CATBaseDispatch) _
    As INFITF.CATBaseDispatch
    
    Set AsDisp = o
    
End Function

'座標系の一致
'Docが一致しｼﾞｵﾒﾄﾘ的に一致していれば、一致と判断
Private Function IsEqAxis( _
    ByVal ax1 As AxisSystem, _
    ByVal ax2 As AxisSystem) _
    As Boolean
    
    IsEqAxis = False
    
    If ax1 Is Nothing And ax2 Is Nothing Then
        IsEqAxis = True
        Exit Function
    End If
    
    If ax1 Is Nothing Or ax2 Is Nothing Then
        Exit Function
    End If
    
    Dim doc1 As Document
    Set doc1 = GetDocument(ax1)
    
    Dim doc2 As Document
    Set doc2 = GetDocument(ax2)
    
    If Not IsEqDoc(doc1, doc2) Then Exit Function
    
    Dim ori1(2) As Variant
    AsDisp(ax1).GetOrigin ori1
    
    Dim ori2(2) As Variant
    AsDisp(ax2).GetOrigin ori2
    
    If Not KCL.IsAryEqual(ori1, ori2) Then Exit Function
    
    Dim vecX1(2) As Variant
    Dim vecY1(2) As Variant
    AsDisp(ax1).GetVectors vecX1, vecY1
    
    Dim vecX2(2) As Variant
    Dim vecY2(2) As Variant
    AsDisp(ax2).GetVectors vecX2, vecY2
    
    If Not KCL.IsAryEqual(vecX1, vecX2) Then Exit Function
    If Not KCL.IsAryEqual(vecY1, vecY2) Then Exit Function
    
    IsEqAxis = True
    
End Function

'ﾄﾞｷｭﾒﾝﾄの一致
'doc1 is doc2 では上手く行かない時がある
Private Function IsEqDoc( _
    ByVal doc1 As Document, _
    ByVal doc2 As Document) _
    As Boolean
        
    IsEqDoc = IIf(doc1.FullName = doc2.FullName, _
                  True, _
                  False)
    
End Function

'ﾄﾞｷｭﾒﾝﾄが開かれているか? 正しくは可視か?
Private Function IsOpenDoc( _
    ByVal doc As Document) _
    As Boolean
    
    IsOpenDoc = True
    
    Dim ws As Windows
    Set ws = CATIA.Windows
    
    Dim w As Window
    For Each w In ws
        If IsEqDoc(w.Parent, doc) Then Exit Function
    Next
    
    IsOpenDoc = False
    
End Function

'座標系変更
Private Sub ChangeAxis( _
    ByVal lst As Collection, _
    ByVal ax As AxisSystem, _
    ByVal pro As Product)
    
    CATIA.RefreshDisplay = False
    
    Dim br As DrawingViewGenerativeBehavior
    
    For Each br In lst
        br.SetAxisSysteme pro, ax
        br.ForceUpdate
    Next
    
    CATIA.RefreshDisplay = True
    
End Sub

'GenerativeBehavior取得 ﾛｯｸも解除
Private Function GetGenBehaviorList( _
    ByVal vis As Collection) As Collection
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim vi As DrawingView
    For Each vi In vis
        vi.LockStatus = False
        lst.Add vi.GenerativeBehavior
    Next
    
    Set GetGenBehaviorList = lst
    
End Function

'確認ﾒｯｾｰｼﾞ作成
Private Function CreateMsg( _
    ByVal vi As DrawingView, _
    ByVal vis As Collection, _
    ByVal BeforeAx As AxisSystem, _
    ByVal AfterAx As AxisSystem)
    
    Dim msg As String
    msg = vi.Name & "の投影基準を" & vbCrLf
    
    If Not BeforeAx Is Nothing Then
        msg = msg & "[" & BeforeAx.Name & "]から"
    End If
    msg = msg & "[" & AfterAx.Name & "]" & vbCrLf & _
        "に変更します。" & vbCrLf
        
    If vis.Count > 0 Then
        msg = msg & "又、以下のﾋﾞｭｰが影響を受けます" & vbCrLf & _
            ExtractViewsName(vis) & _
            "(☆印はﾛｯｸを強制解除します)" & vbCrLf
    End If
    
    CreateMsg = msg & "変更し強制更新を実行しますか?"
    
End Function

'ﾘｽﾄ内ﾋﾞｭｰ名取得 - ﾛｯｸされているものは☆付き
'ついでに選択
Private Function ExtractViewsName( _
    ByVal lst As Collection)
    
    Dim sel As selection
    Set sel = CATIA.ActiveDocument.selection
    
    Dim msg As String
    Dim vi As DrawingView
    
    CATIA.HSOSynchronized = False
    sel.Clear
    
    For Each vi In lst
        If vi.LockStatus Then
            msg = msg & "☆"
        Else
            msg = msg & "・"
        End If
        sel.Add vi
        msg = msg & vi.Name & vbCrLf
    Next
    
    CATIA.HSOSynchronized = True
    
    ExtractViewsName = msg
    
End Function

'新たな座標系選択
Private Function SelectAxis( _
    ByVal msg As String, _
    ByRef refAx As AxisSystem, _
    ByRef lst As Collection) _
    As AxisSystem
    
    Set SelectAxis = Nothing
    
    Dim ax As AxisSystem
    Dim selDoc As Document
    
    Do
        Set ax = SelectItem4(msg, msg, Array("AxisSystem"))
        If ax Is Nothing Then Exit Function
        
        Set selDoc = GetDocument(ax)
        
        Select Case True
            Case Not IsExistsList(lst, selDoc)
                MsgBox msg, vbExclamation
            Case IsEqAxis(ax, refAx)
                MsgBox "変更前と同じ座標系です", vbExclamation
            Case Else
                Set SelectAxis = ax
                Exit Function
        End Select
continue:
    Loop
    
End Function

'指定ﾋﾞｭｰに関連しているﾋﾞｭｰの取得
Private Function GetReferringViewList( _
    ByVal refVi As DrawingView) _
    As Collection
    
    Dim vis As DrawingViews
    Set vis = refVi.Parent
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim lstCnt As Long
    lst.Add refVi
    
    Dim vi As DrawingView
    Do
        lstCnt = lst.Count
        For Each vi In vis
        
            '既にﾘｽﾄに登録
            If IsExistsList(lst, vi) Then GoTo continue
            
            '分離
            If IsIsolate(vi) Then GoTo continue
            
            '拡大図
            If IsExistsList(lst, vi.GenerativeBehavior.ParentView) Then
                    lst.Add vi
                    GoTo continue
            End If
            
            '正面図等
            If Not vi.ReferenceView Is Nothing And _
                IsExistsList(lst, vi.ReferenceView) Then
                    lst.Add vi
                    GoTo continue
            End If
continue:
        Next
    Loop Until lstCnt = lst.Count
    
    Set GetReferringViewList = lst

End Function

'ﾘｽﾄ内に同じものがあるか?
Private Function IsExistsList( _
    ByVal lst As Collection, _
    ByVal itm As AnyObject) _
    As Boolean
    
    IsExistsList = True
    
    Dim oj As AnyObject
    
    'docだけはfullname
    If InStr(1, typename(itm), "Document") > 0 Then
        For Each oj In lst
            If IsEqDoc(oj, itm) Then Exit Function
        Next
    Else
        For Each oj In lst
            If oj Is itm Then Exit Function
        Next
    End If
    IsExistsList = False
    
End Function

'分離?
Private Function IsIsolate( _
    ByVal vi As DrawingView) _
    As Boolean
    
    On Error Resume Next
    
    Dim dmy As AnyObject
    Set dmy = vi.GenerativeBehavior.Document
    
    On Error GoTo 0
    Err.Number = 0
    
    IsIsolate = IIf(dmy Is Nothing, True, False)
    
End Function

'ﾋﾞｭｰの持つ座標系取得 - nothingを返す事も有り
Private Function GetRefAxis( _
    ByVal vi As DrawingView, _
    ByVal pro As Product) _
    As AxisSystem
    
    Dim br As DrawingViewGenerativeBehavior
    Set br = vi.GenerativeBehavior
    
    On Error Resume Next
    
    Dim ax As AxisSystem
    Call br.GetAxisSysteme(pro, ax)
    
    On Error GoTo 0
    Err.Number = 0
    
    Set GetRefAxis = ax
    
End Function

'ﾋﾞｭｰ選択
Private Function SelectView( _
    ByVal msg As String) _
    As DrawingView
    
    Set SelectView = Nothing
    
    Do
        Dim vi As DrawingView
        Set vi = KCL.SelectItem(msg, "DrawingView")
        If vi Is Nothing Then Exit Function
                
        'ﾛｯｸ
        If vi.LockStatus Then
            MsgBox "ﾛｯｸされています", vbExclamation
            GoTo continue
        End If
        
        Select Case True
        
            '分離
'            Case IsIsolate(vi)
'                MsgBox "分断されたﾋﾞｭｰは無効です", vbExclamation
            
            '拡大図
            Case Not (vi.GenerativeBehavior.ParentView Is Nothing)
                MsgBox "基準ﾋﾞｭｰのみです", vbExclamation
            
            '参照有り
            Case Not (vi.ReferenceView Is Nothing)
                MsgBox "基準ﾋﾞｭｰのみです", vbExclamation
                
            'ok
            Case Else
                Set SelectView = vi
                Exit Function
        End Select
continue:
    Loop

End Function

'指定objからﾄﾞｷｭﾒﾝﾄを取得
Private Function GetDocument( _
    ByVal oj As AnyObject) _
    As Document
    
    On Error Resume Next
        Set GetDocument = oj.GetItem("ModelElement").Document
    On Error GoTo 0
    If GetDocument Is Nothing Then
        'Topological,Geometry的なもの(CATSelectionFilter)はこちらで処理
        Set GetDocument = GetParent_Of_Document(oj)
    End If
    
End Function

'指定objからtParentでﾄﾞｷｭﾒﾝﾄを取得
Private Function GetParent_Of_Document( _
    ByVal oj As AnyObject) _
    As AnyObject

    Set GetParent_Of_Document = Nothing
    
    If typename(oj) = typename(oj.Parent) Then
        Exit Function
    End If
    
    If InStr(1, typename(oj), "Document") > 0 Then
        Set GetParent_Of_Document = oj
    Else
        Set GetParent_Of_Document = _
            GetParent_Of_Document(oj.Parent)
    End If
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, _
                                   True, 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

破壊力が抜群過ぎて注意すべき点が多数有ります。
又、（コード的に）本来チェックすべき事があるはずだろうと
思うのですが、設定が多彩過ぎて全てのパターンをテスト出来ずに
いるのも本音です。（特にCGRが含まれた場合等）

注意すべき点等は後日に記載します。
Blogでの長いコードの記載に限界を感じています。本気で考えなきゃ。