ｵﾌｾｯﾄ平面をﾘﾈｰﾑ3

また、面倒くさい虫が現れました。
大量のPartファイルが有り、一枚一枚平面名を修正するのが面倒です。

以前は、ｵﾌｾｯﾄ平面の親子関係を取得できないので断念していたのですが、
平面名が変更されなくなるまで強制的にループさせてしまおう　と思い付き
Partファイル内のｵﾌｾｯﾄ平面をまとめて処理させるようにしました。

'vba Part_OffsetPleneRename_ver0.0.3  using-'KCL0.0.12'  by Kantoku

'ver0.0.1:完成
'ver0.0.2:座標系平面対応
'ver0.0.3:全体を自動化

Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'ｵﾌｾｯﾄ平面
    Dim offs As Object
    Set offs = GetPlaneOffset()
    If offs Is Nothing Then
        MsgBox "修正すべきｵﾌｾｯﾄ平面が有りませんでした", vbInformation
        Exit Sub
    End If
    
    '確認
    Dim msg As String
    msg = offs.count & "個のｵﾌｾｯﾄ平面があります。" & vbCrLf & _
        "ﾘﾈｰﾑを試みますか?"
    If MsgBox(msg, vbYesNo + vbQuestion) = vbNo Then Exit Sub
    
    '実行前ﾈｰﾑﾘｽﾄ
    Dim before As Object
    Set before = GetPlaneNameLst(offs)
    
    'ﾘﾈｰﾑ
    Call ExecRename(offs)
    
    '変更ﾘｽﾄ
    Dim changes As Object
    Set changes = GetChangeLst(offs, before)
    
    '結果
    If changes Is Nothing Then
        msg = "変更有りませんでした"
    Else
        msg = "以下を変更しました" & vbCrLf & _
            String(20, "-") & vbCrLf & _
            Join(changes.ToArray(), vbCrLf)
    End If
    
    CATIA.RefreshDisplay = True
    MsgBox msg, vbInformation

End Sub

'参照元座標系時の新たな平面名取得
Private Function GetAxisPlaneName(ByVal pln As Plane) As String
    GetAxisPlaneName = vbNullString
    
    Dim info As Variant
    info = GetBrepInfo(pln.Plane.DisplayName)
    
    Dim pt As part
    Set pt = KCL.GetParent_Of_T(pln, "Part")
    
    Dim inter As String
    Dim ax As AxisSystem
    Dim hit As AxisSystem: Set hit = Nothing
    
    For Each ax In pt.AxisSystems
        inter = KCL.GetInternalName(ax)
        If inter = info(0) Then
            Set hit = ax
            Exit For
        End If
    Next
    If hit Is Nothing Then Exit Function
    
    Dim direction As String
    Select Case info(1)
        Case 1 'XY平面
            direction = "Z"
        Case 2 'YZ平面
            direction = "X"
        Case 3 'ZX平面
            direction = "Y"
        Case Else
            '多分無いはず。止まったら連絡下さい
            Stop
    End Select
    GetAxisPlaneName = hit.name & "_" & direction & "="
End Function

'BrapNameから参照情報取得
Private Function GetBrepInfo(ByVal BrepName As String) As Variant
    Dim tmp As Variant
    tmp = Split(BrepName, "RSur:(Face:(Brp:(")
    tmp = Split(tmp(1), ")")
    GetBrepInfo = Split(tmp(0), ";")
End Function

'数値を+-付きの文字にする
Private Function Num2Str(ByVal Num As Double) As String
    Num2Str = IIf(Num > 0, "+", "") & CStr(Num)
End Function
 
'新たな平面名取得
Private Function GetPlaneName(ByVal RefPlnName As Reference) As String
    Select Case RefPlnName.DisplayName
        Case "xy plane", "XY平面"
            GetPlaneName = "Z"
        Case "yz plane", "YZ平面"
            GetPlaneName = "X"
        Case "zx plane", "ZX平面"
            GetPlaneName = "Y"
        Case Else
            GetPlaneName = RefPlnName.DisplayName
    End Select
End Function

'ﾘﾈｰﾑする可能性のある平面ﾘｽﾄ取得
Private Function GetPlaneOffset() As Object

    Set GetPlaneOffset = Nothing
    
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    CATIA.HSOSynchronized = False
    
    sel.Clear
    sel.Search "CATPrtSearch.GSMPlaneOffset,all"
    If sel.Count2 < 1 Then Exit Function
    
    Dim lst As Object
    Set lst = KCL.InitLst()
    
    Dim i As Long
    Dim pln As Plane
    For i = 1 To sel.Count2
        Set pln = sel.Item(i).Value
        If IsReferencePlane(pln) Then
            lst.Add pln
        End If
    Next
    sel.Clear
    CATIA.HSOSynchronized = True
    
    If lst.count < 1 Then Exit Function
    
    Set GetPlaneOffset = lst
End Function

'参照元は平面か？
Private Function IsReferencePlane( _
    ByVal pln As Plane) As Boolean
    
    IsReferencePlane = True
    
    If InStr(pln.Plane.DisplayName, "RSur:") > 0 Then
        '座標系の可能性
        Dim newName As String
        newName = GetAxisPlaneName(pln)
        If Len(newName) < 1 Then
            IsReferencePlane = False
        End If
    End If
End Function

'平面名ﾘｽﾄ
Private Function GetPlaneNameLst( _
    plns As Object) As Object
    
    Dim lst As Object
    Set lst = KCL.InitLst()
    
    Dim p As Plane
    For Each p In plns
        lst.Add p.name
    Next
    
    Set GetPlaneNameLst = lst
End Function

'ﾘﾈｰﾑ実行
Private Sub ExecRename( _
    plns As Object)
    
    Dim pln As Plane
    Dim newName As String
    Dim changeFG As Boolean
    
    Do
        changeFG = False
        
        For Each pln In plns
            If InStr(pln.Plane.DisplayName, "RSur:") > 0 Then
                newName = GetAxisPlaneName(pln)
            Else
                newName = GetPlaneName(pln.Plane)
            End If
            
            newName = newName & _
                Num2Str(pln.Offset.Value * pln.Orientation) & "mm"
            
            If Not pln.name = newName Then
                'ﾘﾈｰﾑ
                pln.name = newName
                changeFG = True
            End If
        Next
        
        If Not changeFG Then Exit Do
    Loop
End Sub

'変更された平面名のみ取得
Private Function GetChangeLst( _
    plns As Object, _
    before As Object) As Object
    
    Set GetChangeLst = Nothing
    
    Dim lst As Object
    Set lst = KCL.InitLst()
    
    Dim i As Long
    For i = 0 To plns.count - 1
        If Not plns(i).name = before(i) Then
            lst.Add before(i) & " -> " & plns(i).name
        End If
    Next
    
    If lst.count < 1 Then Exit Function
    
    Set GetChangeLst = lst
End Function

平面1　->　平面2　->　平面3　->　平面1　->　・・・
の様に参照元が循環ループ状態になっているのはCATIA自身で
チェックしてくれているので、無限ループには陥らないはず。

C#ATIA

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

ｵﾌｾｯﾄ平面をﾘﾈｰﾑ3