C#ATIA

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

トップ > VBA

曲線の始点終点どっちが近いのかな？判断

CATIA_V5 VBA

これ、誰も答えないのでマクロを作ろうかな？　と思っているのですが
Catia VBA startpoint, endpoint - DASSAULT: CATIA products - Eng-Tips
思ったより手強い。

スプラインだけじゃなく、直線・円弧にも対応させて、
閉じているかどうかもチェックしたいのですが、時間が無いです。

直線：FirstUptoElemとSecondUptoElemでリファレンス取得し距離測定

円弧：中心と半径と始点ベクトルと終点ベクトル使ってかな？
　　　始点終点のリファレンスは取れないのかな？
r1 HybridShapeCircle (Object)

スプライン：GetNbControlPointでポイント数取得して
　　　　　　GetPointで最初と最後のリファレンス取得し距離測定かな？
r1 HybridShapeSpline (Object)


一時的に曲線上に点を作成して、距離測定したほうが手っ取り早いのに･･･。
HybridShapeFactory内だけで処理すれば、ゴミ残らないんだけどなぁ。

ショートカットキーにマクロを登録する

CATIA_V5 VBA

こちらのコメントで御質問頂いただきました。

最初の質問の方です。式では該当する機能があるものかどうか、不明です。
マクロであれば形状セット数の取得は簡単に出来ます。

'vba パラメータに形状セット数を表示する

Sub CATMain()
    '本来ならドキュメントの型をチェックすべきです。
    'Part以外がアクティブな場合エラーになります。
    
    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    Dim pt As Part
    Set pt = doc.Part
    
    Dim prms As Parameters
    Set prms = pt.Parameters
    
    'パラメータ取得
    Dim prm As IntParam
    Set prm = GetPrm(prms, "形状セット数")

    '形状セット数
    Dim hBdyCount As Long
    hBdyCount = GetHBodyCount(doc)
    
    'パラメータ値に反映
    prm.Value = hBdyCount
End Sub

Private Function GetHBodyCount( _
    ByVal doc As Document) As Long
    
    Dim sel As selection
    Set sel = doc.selection
    
    CATIA.HSOSynchronized = False
    
    sel.Clear
    sel.Search "CATPrtSearch.OpenBodyFeature,all"
    GetHBodyCount = sel.Count2
    sel.Clear
    
    CATIA.HSOSynchronized = True
End Function

Private Function GetPrm( _
    ByVal prms As Parameters, _
    ByVal name As String) As IntParam
    
    If IsExistPrm(prms, name) Then
        Set GetPrm = prms.Item(name)
    Else
        Set GetPrm = InitParm(prms, name)
    End If
End Function

Private Function IsExistPrm( _
    ByVal prms As Parameters, _
    ByVal name As String) As Boolean
    
    Dim intPrm As IntParam
    
    On Error Resume Next
        Set intPrm = prms.Item(name)
    On Error GoTo 0

    IsExistPrm = IIf(intPrm Is Nothing, False, True)
End Function

Private Function InitParm( _
    ByVal prms As Parameters, _
    ByVal name As String) As IntParam

    Set InitParm = prms.CreateInteger("", 0)
    InitParm.Rename name
End Function

紛らわしい為、パラメータ名は "形状セット数" としました。
Partファイルでのみですが、実行すれば取得できます。
f:id:kandennti:20190130141205p:plain

ここで困難なのは "リアルタイムで" の部分です。
プログラム的に考えれば、変化が起きたタイミングの検知し
このマクロを実行すれば良いのですが、通常であれば
イベント処理が真っ先に思いつきます。　
が、生憎CATIAのマクロでは、そのようなイベント処理を
行うことは出来ないだろうと思います。

おぼろげな記憶なのですが、やはり "リアルタイムで" を実行する
代案として「unofficial catia user forum」にここなさんが記載していた
アイデアをご紹介します。

作業中に頻繁に使用するショートカットキーがあるでしょうか？
仮にこれが「Treeの表示/非表示」だとします。（僕は偶にです･･･）
デフォルトであれば F3キーとなっています。
このF3キーを押した際、「Treeの表示/非表示」とマクロの実行を
一度で行えるようにする　と言うアイデアです。

すんなり出来ない、ショートカットキーのカスタマイズについては
こちらのサイトに詳しく記載されています。
〇CATIAの小技
登録できないアクセサレーターを登録する方法 | CATIAの小技

1）重複したシュートカットキーの登録が出来ない為、一度F3キーを
フリーにします。
f:id:kandennti:20190130141234p:plain
日本語環境の場合ですが、「Treeの表示/非表示」は「仕様」と言う
コマンド名です。（知らなかった･･･）
アクセレータに「F3」が記載されていますので、これを空欄にします。


2）「CATIAの小技」さんの手法でツールバーを作成します。


3）「CATIAの小技」さんの手法でツールバーにマクロをD&Dします。
　念のため、ツールバーに登録する前は、アクセレータはグレーアウトして
　設定できません。
f:id:kandennti:20190130141256p:plain
　登録するとアクセレータでの設定が可能となりますので、「F3」と
　記入すればOKです。
f:id:kandennti:20190130141309p:plain


4）これでF3キーでマクロは実行するようになりますが、元の
　「Treeの表示/非表示」が出来なくなってしまいます。その為
　最初のマクロを少し修正します。

'vba パラメータに形状セット数を表示する

Sub CATMain()
    '本来ならドキュメントの型をチェックすべきです。
    'Part以外がアクティブな場合エラーになります。
    
    '仕様コマンド
    CATIA.StartCommand "仕様"
    
    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument

    '以下は同じです    
・
・
・

このようにすることで、Treeの表示/非表示」とマクロの実行を
一度で行えるようなります。
・・・ちっともリアルタイムには、ならないのですが。

上書き保存確認ダイアログでの判断

CATIA_V5 VBA

「SaveAsで保存する際、上書き保存確認ダイアログで
　"はい" を選択したか "いいえ" を選択したか、判断したい」
と御質問を頂きました。

SaveAsメソッドは戻り値がない為、保存前と保存後のタイムスタンプで
判断するしか方法が無いような気がします。

'vba
Sub CATMain()
    
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    Dim before As Date
    before = GetDateLastModified(doc.FullName)
    
    '上書きでいいえの場合エラーになる為
    On Error Resume Next
        doc.SaveAs doc.FullName
    On Error GoTo 0
    
    If before = GetDateLastModified(doc.FullName) Then
        MsgBox "保存されていません"
    Else
        MsgBox "保存されました"
    End If
    
End Sub

Private Function GetDateLastModified( _
    ByVal path As String) As Date
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    GetDateLastModified = fso.GetFile(path).DateLastModified
End Function

色々を確認が足りないと思いますが、一応判断出来ていると思います。
過去に、マクロで保存を行うことに対しての賛否はありましたが･･･。

Tree順にボディ,形状セット,時系列形状セット名の取得

CATIA_V5 VBA

先日見つけたこちらのトピですが、
CATIA V5 - CATScript - Identify Order of Geometric Sets and Bodies in CATPart - DASSAULT: CATIA products - Eng-Tips
Treeに並んでいる順に、ボディと形状セット名を取得したい
と言う内容です。

検索で選択状態にすれば、Tree順に取得出来たはずなので
サンプルを作ってみたのですが、よく読んだら解決されていた
いたようでした・・・。　折角作ったので記載しておきます。

Treeに直接ぶら下がっているものだけで、子以下のものは取得しません。

'VBA Tree順にボディ,形状セット,時系列形状セット名の取得

Option Explicit

Sub CATMain()

    'start check
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'doc
    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    'AllContainer
    Dim bodys As Object
    Set bodys = GetAllContainers(doc)
    If bodys Is Nothing Then
        MsgBox "Element not found", vbExclamation
        Exit Sub
    End If
    
    'LeafContainer
    Set bodys = GetLeafContainerNames(doc, bodys)
    If bodys Is Nothing Then
        MsgBox "Element not found", vbExclamation
        Exit Sub
    End If
    
    'done
    MsgBox Join(bodys.ToArray(), vbCrLf)
End Sub

Private Function GetAllContainers( _
    ByVal doc As PartDocument) As Object
    
    Set GetAllContainers = Nothing
    
    Dim sel As selection
    Set sel = doc.selection
    
    'Search
    Dim word As String
    word = "(CATPrtSearch.BodyFeature + " & _
            "CATPrtSearch.OpenBodyFeature + " & _
            "CATPrtSearch.MMOrderedGeometricalSet),in"
    
    CATIA.HSOSynchronized = False
    sel.Clear
    
    sel.Search word
    If sel.Count2 < 1 Then Exit Function
    
    Dim ary As Object
    Set ary = InitLst()
    
    Dim i As Long
    For i = 1 To sel.Count2
        ary.Add sel.Item(i).Value
    Next
    
    sel.Clear
    CATIA.HSOSynchronized = True
    
    Set GetAllContainers = ary
End Function

Private Function GetLeafContainerNames( _
    ByVal doc As PartDocument, _
    ByVal lst As Object) As Object
    
    Set GetLeafContainerNames = Nothing
    
    'Leaf HybridBodies
    Dim hBdys As Variant
    hBdys = Lst2Ary(doc.Part.HybridBodies)
    
    'Leaf OrderedGeometricalSets
    Dim odrds As Variant
    odrds = Lst2Ary(doc.Part.OrderedGeometricalSets)
    
    'is Leaf?
    Dim leafs As Object
    Set leafs = InitLst()
    
    Dim v As Variant
    For Each v In lst
        Select Case TypeName(v)
            Case "Body"
                If v.InBooleanOperation = False Then
                    leafs.Add v.Name
                End If
            Case "HybridBody"
                If UBound(filter(hBdys, GetInternalName(v))) > -1 Then
                    leafs.Add v.Name
                End If
            Case "OrderedGeometricalSet"
                If UBound(filter(odrds, GetInternalName(v))) > -1 Then
                    leafs.Add v.Name
                End If
        End Select
    Next
    If leafs.count < 1 Then Exit Function
    
    Set GetLeafContainerNames = leafs
End Function

'list2array
Private Function Lst2Ary( _
    ByVal lst As Object) As Variant

    If lst.count < 1 Then Exit Function

    Dim ary As Object
    Set ary = InitLst()
    
    Dim v As Variant
    For Each v In lst
        ary.Add GetInternalName(v)
    Next
    
    Lst2Ary = ary.ToArray()
End Function

'InternalName
Private Function GetInternalName( _
    ByVal AOj As AnyObject) As String
    If AOj Is Nothing Then
        GetInternalName = Empty
        Exit Function
    End If
    GetInternalName = AOj.GetItem("ModelElement").InternalName
End Function

'DotNet ArrayList
Private Function InitLst() As Object
    Set InitLst = CreateObject("System.Collections.ArrayList")
End Function

'OK?
Private Function CanExecute( _
    ByVal docType As String) As Boolean
    
    CanExecute = False
    
    If CATIA.Windows.count < 1 Then
        MsgBox "Please open the file", vbExclamation
        Exit Function
    End If
    
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    If Not TypeName(doc) = docType Then
        MsgBox docType & " Only!", vbExclamation
        Exit Function
    End If
    
    CanExecute = True
End Function

f:id:kandennti:20190112084014p:plain

異なるUUIDのDraw参照元ファイルを差し替える3

CATIA_V5 VBA KCL

こちらの続きです。
異なるUUIDのDraw参照元ファイルを差し替える2 - C#ATIA

あちらのマクロを実際に業務で使用していると、リンクを持たないビューまで
リンク付きのビューにしてしまう為、使い勝手が非常に悪かったです。

その為、リンク元を差し替えるビューをユーザーが選択できるように
変更しました。

'vba ChangeDrawLink ver0.0.2  using-'KCL0.0.12'  by Kantoku
'Drawのﾋﾞｭｰのﾘﾝｸの参照元を差し替える
'Partのみ?で　UUID違いOK

'ver0.0.1:完成
'ver0.0.2:ﾋﾞｭｰを指定するように変更

Option Explicit

Private Const SelectionType = "*.CATPart"

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'view選択
    Dim Msg As String
    Msg = "置き換えるﾋﾞｭｰを選択してください"
    
    Dim views As Collection
    Set views = SelectViews(Msg)
    If views Is Nothing Then Exit Sub
    If views.Count < 1 Then Exit Sub
    
    'ﾌｧｲﾙ選択
    Msg = "Drawで参照するﾌｧｲﾙを選択してください"
    
    Dim path As String
    path = CATIA.FileSelectionBox( _
        Msg, _
        SelectionType, _
        CatFileSelectionModeOpen)
    If path = vbNullString Then Exit Sub
    
    'Draw
    Dim drawDoc As DrawingDocument
    Set drawDoc = CATIA.ActiveDocument
    
    '確認
    Msg = "以下のビュー" & vbCrLf & _
        GetViewsName(views) & _
        "を、リンクの参照元" & vbCrLf & _
        path & vbCrLf & _
        "に置き換えます。宜しいですか?"
        
    If MsgBox(Msg, vbYesNo + vbQuestion) = vbNo Then Exit Sub
    
    Dim viws As DrawingViews
    Set viws = drawDoc.Sheets.ActiveSheet.views
    
    '参照ｵｰﾌﾟﾝ
    Dim refDoc As Document
    Set refDoc = CATIA.Documents.Open(path)
    
    'すり替え
    Dim vi As DrawingView
    
    For Each vi In views
        Call ChangeLink(vi, refDoc)
    Next
    
    '参照ｸﾛｰｽﾞ
    Call refDoc.Close
    
    MsgBox "Done"
End Sub

'ﾋﾞｭｰの選択
Private Function SelectViews( _
    ByVal Msg As String) As Collection

    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.selection

    Dim filter As Variant
    filter = Array("DrawingView")

    sel.Clear
    Select Case sel.SelectElement3(filter, Msg, True, _
        CATMultiSelTriggWhenUserValidatesSelection, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select

    Dim lst As Collection
    Set lst = New Collection

    Dim i As Long
    For i = 1 To sel.Count2
        lst.Add sel.Item(i).Value
    Next
    sel.Clear

    Set SelectViews = lst
End Function

'ｺﾚｸｼｮﾝ内のﾋﾞｭｰ名をﾃｷｽﾄ化
Private Function GetViewsName( _
    ByVal lst As Collection) As String

    Dim ary() As String
    ReDim ary(lst.Count)
    
    Dim i As Long
    For i = 1 To lst.Count
        ary(i - 1) = lst.Item(i).Name
    Next
    
    GetViewsName = Join(ary, vbCrLf)
End Function

'すり替え&Update
Private Sub ChangeLink( _
    ByVal viw As DrawingView, _
    ByVal doc As Document)

    Dim links As DrawingViewGenerativeLinks
    Set links = viw.GenerativeLinks
    links.RemoveAllLinks

    Dim behv As DrawingViewGenerativeBehavior
    Set behv = viw.GenerativeBehavior

    behv.Document = doc
    behv.Update
End Sub

マクロ実行後、ビューを選択（複数選択可能です）し、続いて
リンク元となるPartファイルを指定すればOKです。
指定するPartファイルはUUIDの一致不一致を問いません。

唯一の欠点は、更新後本来寸法解析した際赤くなるべき寸法が
何食わぬ顔して（黒のまま）終了してしまう事です。
これは更新しても直りません。

対策としては、再度手動でリンク元を同じファイルで置換し更新すれば
OKなのですが手間と言えばかなり手間です。

但し、UUID違いは手動ではリンク元を置換できない為、個人的には
かなり重宝します。

そして、リンクを分断したビューでもリンクを復活させる事も可能です！
（もちろん寸法はﾁﾏﾁﾏ直す必要は有ります）

形状ｾｯﾄ要素の対称化ﾏｸﾛ2

CATIA_V5 VBA

こちらの続きです。
形状ｾｯﾄ要素の対称化ﾏｸﾛ - C#ATIA

元の対称化するマクロですが、色の反映を追加しました。

'vba 指定した形状ｾｯﾄを対称化しｺﾋﾟﾍﾟ2
Option Explicit

Dim PartDoc As PartDocument
Dim Part As Part
Dim sel 'As Selection
Dim HSFact As HybridShapeFactory
Dim BasePlane As Reference
Dim DeleteItems As New Collection

Sub CATMain()
    '初期設定
    Set PartDoc = CATIA.ActiveDocument
    Set Part = PartDoc.Part
    Set sel = PartDoc.selection
    
    '元の形状ｾｯﾄ選択
    Dim BaseHBody As HybridBody
    Set BaseHBody = SelectHybridBody
    
    '対象平面選択
    Set BasePlane = SelectPlanarFace
    
    '形状ｾｯﾄｺﾋﾟﾍﾟ
    Dim MirrerHBody As HybridBody
    Set MirrerHBody = CopyPasteHybridBody(BaseHBody)
    MirrerHBody.Name = BaseHBody.Name + "_Symmetry"
    
    '対称化
    Set HSFact = Part.HybridShapeFactory
    Call HBodyLoop(MirrerHBody)
    
    '終了
    Call DeleteItem
    Part.Update
    MsgBox ("終了")
End Sub

'ｺﾋﾟﾍﾟした要素を削除
Private Sub DeleteItem()
    Dim Ref As Reference
    For Each Ref In DeleteItems
        Call HSFact.DeleteObjectForDatum(Ref)
    Next
End Sub

'形状ｾｯﾄﾙｰﾌﾟ-再帰
Private Sub HBodyLoop(HBody As HybridBody)
    Call SymmetryItem(HBody.HybridShapes)
    If HBody.HybridBodies.Count = 0 Then Exit Sub '下階層無し
    
    Dim HB As HybridBody
    For Each HB In HBody.HybridBodies
        Call HBodyLoop(HB)
    Next
End Sub

'対称
Private Sub SymmetryItem(HShapes As HybridShapes)
    Dim HShape As HybridShape
    Dim Ref As Reference
    Dim rgb As Variant
    Dim sym As HybridShape
    
    For Each HShape In HShapes
        Set Ref = Part.CreateReferenceFromObject(HShape)
        rgb = GetColor(HShape)
        If HSFact.GetGeometricalFeatureType(Ref) <> 0 Then
            Call DeleteItems.Add(Ref) '削除登録
            Set sym = CreateDatum(CreateSymmetry(Ref, BasePlane))
            Call setColor(sym, rgb)
            Call HShapes.Parent.AppendHybridShape(sym)
        End If
    Next
End Sub

'色取得
Private Function GetColor( _
    ByVal shape As HybridShape) As Variant
    
    sel.Clear
    sel.Add shape
    
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    
    Dim rgb(2) As Long
    vis.GetRealColor rgb(0), rgb(1), rgb(2)
    
    sel.Clear
    GetColor = rgb
End Function

'色設定
Private Sub setColor( _
    ByVal shape As HybridShape, _
    ByVal rgb As Variant)
        
    sel.Clear
    sel.Add shape
    
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    
    Call vis.SetRealColor(rgb(0), rgb(1), rgb(2), 1)
    sel.Clear
End Sub

'Symmetry
Private Function CreateSymmetry(ItemRef As Reference, PlaneRef As Reference) As Reference
    Dim Symmetry As HybridShapeSymmetry
    Set Symmetry = HSFact.AddNewSymmetry(ItemRef, PlaneRef)
    Symmetry.VolumeResult = False
    Call Part.UpdateObject(Symmetry)
    Set CreateSymmetry = Part.CreateReferenceFromObject(Symmetry)
    Call DeleteItems.Add(CreateSymmetry) '削除登録
End Function

'Datum
Private Function CreateDatum(Ref As Reference) As AnyObject
    Dim Datum As AnyObject
    Select Case HSFact.GetGeometricalFeatureType(Ref)
        Case 1 'Point
            Set Datum = HSFact.AddNewPointDatum(Ref)
        Case 2 'Curve
            Set Datum = HSFact.AddNewCurveDatum(Ref)
        Case 3 'Line
            Set Datum = HSFact.AddNewLineDatum(Ref)
        Case 4 'Circle
            Set Datum = HSFact.AddNewCircleDatum(Ref)
        Case 5 'Surface
            Set Datum = HSFact.AddNewSurfaceDatum(Ref)
        Case 6 'Plane
            Set Datum = HSFact.AddNewPlaneDatum(Ref)
        Case 7 'Volume
            Set Datum = HSFact.AddNewVolumeDatum(Ref)
    End Select
    Call Part.UpdateObject(Datum)
    Set CreateDatum = Datum
End Function

'形状ｾｯﾄのｺﾋﾟﾍﾟ
Private Function CopyPasteHybridBody(HBody As HybridBody) As HybridBody
    With sel
        .Clear
        .Add HBody
        .Copy
        .Clear
        .Add Part
        .Paste
    End With
    With Part.HybridBodies
        Set CopyPasteHybridBody = .Item(.Count)
    End With
End Function

'平面の選択
Private Function SelectPlanarFace() As Reference
    Dim FilterType(0)  As Variant
    FilterType(0) = "PlanarFace"
    Call SelectItem(FilterType, "対称基準となる平面を選択して下さい / ESCｷｰ ｷｬﾝｾﾙ")
    Set SelectPlanarFace = Part.CreateReferenceFromBRepName( _
                    GetBrepName(sel.Item(1).Value.Name), sel.Item(1).Value.Parent)
End Function

'SelectElement用BrapName取得
Private Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

'形状ｾｯﾄ選択
Private Function SelectHybridBody() As HybridBody
    Dim FilterType(0)  As Variant
    FilterType(0) = "HybridBody"
    Call SelectItem(FilterType, "元となる形状ｾｯﾄを選択して下さい / ESCｷｰ ｷｬﾝｾﾙ")
    Set SelectHybridBody = sel.Item(1).Value
End Function

'選択
Private Sub SelectItem(FilterType As Variant, Msg As String)
    sel.Clear
    If sel.SelectElement2(FilterType, Msg, False) = "Cancel" Then End
End Sub

SymmetryItem関数を修正し、GetColor関数、SetColor関数の2個を追加
しました。

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

CATIA_V5 VBA KCL

こちらの続きです。
ｵﾌｾｯﾄ平面をﾘﾈｰﾑ2 - C#ATIA

また、面倒くさい虫が現れました。
大量の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自身で
チェックしてくれているので、無限ループには陥らないはず。