↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)


オフセット平面をリネーム2 - C#ATIA


平面名が変更されなくなるまで強制的にループさせてしまおう と思い付き

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


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 = "変更有りませんでした"
        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
    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
    End Select
    GetAxisPlaneName = hit.name & "_" & direction & "="
End Function

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.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
    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
    Set GetPlaneNameLst = lst
End Function

Private Sub ExecRename( _
    plns As Object)
    Dim pln As Plane
    Dim newName As String
    Dim changeFG As Boolean
        changeFG = False
        For Each pln In plns
            If InStr(pln.Plane.DisplayName, "RSur:") > 0 Then
                newName = GetAxisPlaneName(pln)
                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
        If Not changeFG Then Exit Do
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
    If lst.count < 1 Then Exit Function
    Set GetChangeLst = lst
End Function

平面1 -> 平面2 -> 平面3 -> 平面1 -> ・・・