ｸﾘｯｸした点の座標値を外部ﾌｧｲﾙにｴｸｽﾎﾟｰﾄ

こちらでｺﾒﾝﾄを頂いたので、ﾘﾊﾋﾞﾘがてら作ってみました。
Excelﾌｫｰﾑﾎﾞﾀﾝからﾏｸﾛの起動 (未確認) - C#ATIA

'vba sample_ExpPointPos_ver0.0.1 by Kantoku
'選択した点の座標値をﾌｧｲﾙにｴｸｽﾎﾟｰﾄ
Option Explicit

'*** ｴｸｽﾎﾟｰﾄするﾌｫｰﾏｯﾄを設定して下さい ***
'txt - ｽﾍﾟｰｽ区切り
'csv - ｶﾝﾏ区切り
'xls - Excelに直接（要Excel起動）
Const ExpType = "csv"
'*********

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'ﾄﾞｷｭﾒﾝﾄ
    Dim Doc As PartDocument
    Set Doc = CATIA.ActiveDocument
    
    'ﾄﾞｷｭﾒﾝﾄﾊﾟｽ
    Dim DocPath As Variant
    DocPath = GetDocDir(Doc)
    
    'excelのみ
    If ExpType = "xls" Then
        Dim Xlapp As Object
        Set Xlapp = GetExcel()
    End If
    
    '点選択
    Dim Filter As Variant
    Filter = Array("Point")
    
    Dim Msg As String
    Msg = "点/頂点を選択してください : [Esc]=ｷｬﾝｾﾙ"
    
    Dim Data As Collection '取得データ格納用
    Set Data = GetPointInfo(Msg, Filter)
    
    If Data.Count < 1 Then End 'ﾃﾞｰﾀ無し
    
    'ｴｸｽﾎﾟｰﾄ
    DocPath(1) = DocPath(1) & "_SelPoint"
    Dim ExpPath As String
    Select Case ExpType
        Case "txt"
            ExpPath = ExpTxt(DocPath, Data, " ", "txt")
        Case "csv"
            ExpPath = ExpTxt(DocPath, Data, ",", "csv")
        Case "xls"
            ExpPath = ExpXls(DocPath, Data, Xlapp)
    End Select
    
    Msg = ExpPath & vbNewLine & _
          CStr(Data.Count) & "個分の座標値をｴｸｽﾎﾟｰﾄしました"
    MsgBox Msg
End Sub

'ｴｸｽﾎﾟｰﾄ - excel
Private Function ExpXls(ByVal Path As Variant, ByVal Data As Collection, _
                        ByVal Xlapp As Object) As String
    Dim Wb As Object 'WookBook
    Set Wb = Xlapp.Workbooks.Add
    
    Dim Ws As Object 'WorkSheet
    Set Ws = Wb.ActiveSheet
    
    Dim I As Long, J As Long
    For I = 1 To Data.Count
        For J = 1 To 4
            Ws.Cells(I, J).value = Data(I).Item(J)
        Next
    Next
    
    Path(2) = "xls"
    Dim ExpPath As String
    ExpPath = GetNewName(JoinPathName(Path))
    Call Wb.SaveAs(ExpPath)
    ExpXls = ExpPath
End Function

'Excel取得
Private Function GetExcel() As Object
    Dim Xlapp As Object 'As Excel.Application
    On Error Resume Next
        Set Xlapp = VBA.GetObject(, "Excel.Application")
    On Error GoTo 0
    If IsNothing(Xlapp) Then
        MsgBox "Excelを起動してから再度実行してください"
        End
    End If
    Set GetExcel = Xlapp
End Function

'ｴｸｽﾎﾟｰﾄ - txt,csv
Private Function ExpTxt(ByVal Path As Variant, ByVal Data As Collection, _
                        ByVal Delim As String, ByVal Ext As String) As String
    Dim Tmp As Collection: Set Tmp = New Collection
    Dim Info As Collection
    For Each Info In Data
        Call Tmp.Add(JoinLst(Info, Delim))
    Next
    
    Path(2) = Ext
    Dim ExpPath As String
    ExpPath = GetNewName(JoinPathName(Path))
    Call WriteFile(ExpPath, JoinLst(Tmp, vbNewLine))
    
    ExpTxt = ExpPath
End Function

'ﾘｽﾄ展開
Private Function JoinLst(ByVal Lst As Collection, ByVal Delim As String)
    Dim t As Variant
    Dim res As String
    For Each t In Lst
        res = res & t & Delim
    Next
    JoinLst = Left(res, Len(res) - Len(Delim))
End Function

'座標値取得
Private Function GetPointInfo(ByVal Msg As String, _
                              ByVal Filter As Variant) As Collection
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Dim Data As Collection: Set Data = New Collection
    Dim Info As Collection
    Dim Pnt As Variant 'As Point
    Dim Pos(2) As Variant 'As Double
    
    Do
        Sel.Clear
        Select Case Sel.SelectElement2(Filter, Msg, False)
            Case "Cancel", "Undo", "Redo"
                Exit Do
        End Select
        Set Pnt = Sel.Item(1).value
        Call Pnt.GetCoordinates(Pos)

        Set Info = New Collection
        With Info
            Call .Add(Pnt.Name)
            Call .Add(CStr(Pos(0)))
            Call .Add(CStr(Pos(1)))
            Call .Add(CStr(Pos(2)))
        End With
        Call Data.Add(Info)
    Loop
    Set GetPointInfo = Data
End Function

'ﾄﾞｷｭﾒﾝﾄのﾊﾟｽ取得
Private Function GetDocDir(ByVal Doc As PartDocument) As Variant
    Dim Path As Variant
    Path = SplitPathName(Doc.FullName)
    If Len(Path(0)) < 1 Then
        MsgBox "CATPartﾌｧｲﾙを一度保存してください!!)"
        End
    End If
    GetDocDir = Path
End Function

'*** kclより流用 ***
'こちらを同じﾌﾟﾛｼﾞｪｸﾄ内にKCL.bas(標準ﾓｼﾞｭｰﾙ)として入れてある場合は
'以下のｺｰﾄﾞは不要です。
'http://kantoku.hatenablog.com/entry/2016/06/21/111410
'http://kantoku.hatenablog.com/entry/2016/12/27/194117


'ﾏｸﾛｽﾀｰﾄﾁｪｯｸ
''' @param:DocTypes-array(string),string ﾏｸﾛ実行を許可するﾄﾞｷｭﾒﾝﾄのﾀｲﾌﾟ
''' @return:Boolean
Private Function CanExecute(ByVal DocTypes As Variant) As Boolean
    CanExecute = False
    
    If CATIA.Windows.Count < 1 Then
        MsgBox "ﾌｧｲﾙが開かれていません"
        Exit Function
    End If
    
    If VarType(DocTypes) = vbString Then DocTypes = Split(DocTypes, ",")
    If Not IsFilterType(DocTypes) Then Exit Function
    
    Dim ErrMsg As String
    ErrMsg = "ﾌｧｲﾙのﾀｲﾌﾟが異なります。" + vbNewLine + "(" + Join(DocTypes, ",") + " のみです)"
    
    Dim ActDoc As Document
    On Error Resume Next
        Set ActDoc = CATIA.ActiveDocument
    On Error GoTo 0
    If ActDoc Is Nothing Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    If UBound(Filter(DocTypes, TypeName(ActDoc))) < 0 Then
        MsgBox ErrMsg, vbExclamation + vbOKOnly
        Exit Function
    End If
    
    CanExecute = True
End Function

'ﾌｨﾙﾀｰﾀｲﾌﾟとしてOK?
Private Function IsFilterType(ByVal Ary As Variant) As Boolean
    IsFilterType = False
    Dim ErrMsg$: ErrMsg = "ﾌｨﾙﾀｰ又はﾄﾞｷｭﾒﾝﾄﾀｲﾌﾟの指定は" + vbNewLine + _
                          "Variant(String)型配列で行ってください" + vbNewLine + _
                          "(ﾏｸﾛｺｰﾄﾞのｴﾗｰです)"
    
    If Not IsStringAry(Ary) Then
        MsgBox ErrMsg
        Exit Function
    End If
    
    IsFilterType = True
End Function

'文字型配列?
Private Function IsStringAry(ByVal Ary As Variant) As Boolean
    IsStringAry = False
    
    If Not IsArray(Ary) Then Exit Function
    Dim I&
    For I = 0 To UBound(Ary)
        If Not VarType(Ary(I)) = vbString Then Exit Function
    Next
    
    IsStringAry = True
End Function

'FileSystemObject
''' @return:Object(Of FileSystemObject)
Private Function GetFSO() As Object
    Set GetFSO = CreateObject("Scripting.FileSystemObject")
End Function

'ﾊﾟｽ/ﾌｧｲﾙ名/拡張子 分割
''' @param:FullPath-ﾌｧｲﾙﾊﾟｽ
''' @return:Variant(Of Array(Of String)) (0-Path 1-BaseName 2-Extension)
Private Function SplitPathName(ByVal FullPath$) As Variant
    Dim Path(2) As String
    With GetFSO
        Path(0) = .getParentFolderName(FullPath)
        Path(1) = .GetBaseName(FullPath)
        Path(2) = .GetExtensionName(FullPath)
    End With
    SplitPathName = Path
End Function

'ﾊﾟｽ/ﾌｧｲﾙ名/拡張子 連結
''' @param:Path-Variant(Of Array(Of String)) (0-Path 1-BaseName 2-Extension)
''' @return:ﾌｧｲﾙﾊﾟｽ
Private Function JoinPathName$(ByVal Path As Variant)
    If Not IsArray(Path) Then Stop '未対応
    If Not UBound(Path) = 2 Then Stop '未対応
    JoinPathName = Path(0) + "\" + Path(1) + "." + Path(2)
End Function

'ﾌｧｲﾙ,ﾌｫﾙﾀﾞの有無
''' @param:Path-ﾊﾟｽ
''' @return:Boolean
Private Function IsExists(ByVal Path$) As Boolean
    IsExists = False
    Dim FSO As Object: Set FSO = GetFSO
    If FSO.FileExists(Path) Then
        IsExists = True: Exit Function 'ﾌｧｲﾙ
    ElseIf FSO.FolderExists(Path) Then
        IsExists = True: Exit Function 'ﾌｫﾙﾀﾞ
    End If
    Set FSO = Nothing
End Function

'重複しない名前取得
''' @param:Path-ﾌｧｲﾙﾊﾟｽ
''' @return:新たなﾌｧｲﾙﾊﾟｽ
Private Function GetNewName$(ByVal OldPath$)
    Dim Path As Variant
    Path = SplitPathName(OldPath)
    Path(2) = "." & Path(2)
    Dim NewPath$: NewPath = Path(0) + "\" + Path(1)
    If Not IsExists(NewPath + Path(2)) Then
        GetNewName = NewPath + Path(2)
        Exit Function
    End If
    Dim TempName$, I&: I = 0
    Do
        I = I + 1
        TempName = NewPath + "_" + CStr(I) + Path(2)
        If Not IsExists(TempName) Then
            GetNewName = TempName
            Exit Function
        End If
    Loop
End Function

'ﾌｧｲﾙの書き込み
''' @param:Path-ﾌｧｲﾙﾊﾟｽ
''' @param:Txt-String
Private Sub WriteFile(ByVal Path$, ByVal txt) '$)
    Call GetFSO.OpenTextFile(Path, 2, True).Write(txt)
End Sub

ﾏｸﾛ起動後、大したﾒｯｾｰｼﾞもありませんが点を次々とｸﾘｯｸして頂き
ESCｷｰを押す事でCATPartﾌｧｲﾙと同じﾌｫﾙﾀﾞ内に
"[CATPartﾌｧｲﾙ名]_SelPoint.xxx "
と言う名称のﾌｧｲﾙが出来上がります。
（上書き保存を避けるため、同一名のファイルがある場合 "_[数字]"が追加されます）

・CATPartﾌｧｲﾙがｱｸﾃｨﾌﾞになっている必要が有り、一度保存しておく必要が有ります。
　（保存先ﾊﾟｽを取得する為）
・事前にｺｰﾄﾞを設定する必要がありますが(最初の方の部分です)、対応ﾌｫｰﾏｯﾄは
　txt,csv,xlsです。
・xlsの場合、事前にExcelを起動しておく必要が有ります。
・ｴｸｽﾎﾟｰﾄされたﾌｧｲﾙは以下の状態です。
　[名称 , X値 , Y値 , Z値]
・Excel操作部分のｺｰﾄﾞは、世間の皆様の方がきっと素晴らしいと思います。
・ｺｰﾄﾞ内にも記載しましたが、KCLを利用する場合は後半のｺｰﾄﾞは不要です。
非常に個人的なCATVBA用ﾗｲﾌﾞﾗﾘ - C#ATIA
不覚にも、KCLのご利用をお考えの方へ - C#ATIA

コマンドID

あけましておめでとうございます。
今年もコンセプトがブレたまま、マイペースでやってまいります。

CATIAのｲﾝｽﾄｰﾙﾌｫﾙﾀﾞ内に [.CATNls] の拡張子のﾌｧｲﾙがあるのをご存知でしょうか？
恐らくですが、これらのファイルは画面上に表示されている文字類を
設定するファイルなのだろうと思います。
(言語別にﾌｫﾙﾀﾞで分類されており、言語を切り替え再起動した際
　これらのﾌｧｲﾙが読み込まれ表示される文字が切り替わるのだろうと思います）

海外のサイトで、このファイルについて書かれている記事を何度か見ては
いたのですが、コマンド名に関するものであまり深く受け止めていませんでした。
（今更コマンド名を知った所で、何かﾒﾘｯﾄがあるとは思えなかったので）

年末頃、こちらの記載を見て、何故CATNlsﾌｧｲﾙについて知りたがるのか
やっと理解できました。
CATIA.StartCommand CommandID finden (Dassault Systemes - PLM Solutions/CATIA V5 Programmierung) - Foren auf CAD.de

CATNlsﾌｧｲﾙ内の記載されている右辺のコマンド名が重要なのではなく
左辺に記載されているﾌﾟﾛﾊﾟﾃｨ名が、コマンドIDなのだろう　と言うことのようです。
このコマンドIDは、言語設定に関わらずコマンド呼び出し出来るもののようです。

実際に行った動画です。
最初はコマンドIDとなる [c:CATHpwAxisLineHdr] で実行し
2度目は日本語設定依存となる [c:軸] で実行しています。

確かに、実行できます。

ﾏｸﾛで提供されていないｵﾌﾞｼﾞｪｸﾄを生成する際、最終手段として
[CATIA.StartCommand] を利用せざるを得ない場面があるかも知れませんが
その際、どうしても言語設定を判断し利用する事になります。
（その為にこの辺を作りました
お手軽に言語判定を行いたい - C#ATIA
C#でお手軽に言語判定を行いたい2 - C#ATIA
）
ですが、言語設定に依存しないコマンドIDがわかっていれば、言語判定
すら不要になります。

しかしこのコマンドIDのﾘｽﾄが見つからないんです。
仕方ないので、英語と日本語のﾘｽﾄを作成し、こちらにUpしました。
GrabCAD - CAD library

兎に角、ﾌｧｲﾙ数が多い為ﾌﾘｰｿﾌﾄと簡単なｽﾌﾟﾘｸﾄを作成し、
"Hdr.Title" の記載された行を抜き出し、Excelで整えつつ
軽くﾁｪｯｸしてみただけなので、中身については保証できません。

背景色を変更・復元する3

こちらの続きで、保留していた宿題です。
背景色を変更・復元する2 - C#ATIA

ご要望としては、PartでもProductでも同様の処理を行いたい
と言うことなので、修正してみました。

PartDocumentの取得方法を変更する必要があるため、
こちらの部分を修正します。

Private Sub UserForm_Initialize()
    'Form設定
    Me.CommandButton1.Caption = "背景色-白"
    Me.CommandButton2.Caption = "背景色-復元"
    
    '一時的な背景色
    mBackColor = Array(255, 255, 255)
    
    'CATIA情報
    Set mDoc = Get_PartDoc(CATIA.ActiveDocument)
    If mDoc Is Nothing Then
        MsgBox "Partﾌｧｲﾙが見つかりません"
        Me.CommandButton1.Enabled = False
        Me.CommandButton2.Enabled = False
        Exit Sub
    End If
    Set mPt = mDoc.Part
    Set mSel = mDoc.Selection
    Set mVis = mSel.VisProperties
    Set mVisSetAtt = CATIA.SettingControllers.Item( _
        "CATVizVisualizationSettingCtrl")
End Sub

そして実際にPartDocumentを取得する為の関数を
追加します。(再帰で一番上部にあるPartDocumentを探しています)

Private Function Get_PartDoc(Doc As Document) As PartDocument
    If Not Get_PartDoc Is Nothing Then Exit Function
    
    Dim Pros As Products
    Dim i As Long
    
    Select Case TypeName(Doc)
        Case "PartDocument"
            Set Get_PartDoc = Doc
            Exit Function
    
        Case "ProductDocument"
            Set Pros = Doc.Product.Products
            If Pros.Count < 1 Then Exit Function
            
            For i = 1 To Pros.Count
                Set Get_PartDoc = _
                    Get_PartDoc(Pros.Item(i).ReferenceProduct.Parent)
                If Not Get_PartDoc Is Nothing Then Exit Function
            Next
        
        Case Else
            Exit Function
    End Select
End Function

Part・Product両方で動くﾏｸﾛを作成する際、結論としては
どうやってPartDocumentを取得するか？　だけの違いで他の部分は
共通です行えます。

Productの場合、例えﾃﾞｻﾞｲﾝﾓｰﾄﾞでPartﾌｧｲﾙを操作している状態で
あっても

   set Doc = CATIA.ActiveDocument

を実行した場合、一番上のProductのDocumentが取得されます。
(子ｳｨﾝﾄﾞｳの一番上と言うイメージです)

ｺｯﾎ曲線を描く

こちらの12年も前の記事なのですが、楽しそうなので
CATIAで行ってみました。
再帰プログラムによるフラクタル図形の描画：CodeZine（コードジン）

'vba sample_Koch_Curve_ver0.0.1  using-'KCL0.0.12'  by Kantoku
'xy平面上にｺｯﾎ曲線を作成します
'https://codezine.jp/article/detail/73

Option Explicit

Private Const LEVEL = 3         '再帰ﾚﾍﾞﾙ

Dim mPnts As Object             'Get_KochCurvePos用座標郡
Dim mDoc As PartDocument
Dim mPt As Part
Dim mFact As HybridShapeFactory

'定数代わり
Dim m1_3 As Double              '1/3
Dim m1_Sq3 As Double            '1/sqr(3)
Dim mPI_6 As Double             'PAI/6 = 30deg

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    '初期設定
    m1_3 = 1 / 3
    m1_Sq3 = 1 / Sqr(3)
    mPI_6 = Atn(1) * 4 / 6
    
    Set mDoc = CATIA.ActiveDocument
    Set mPt = mDoc.Part
    Set mFact = mPt.HybridShapeFactory
    
    '頂点座標
    Dim p1, p2, p3
    p1 = Array(100#, 160#)
    p2 = Array(400#, 160#)
    p3 = Array(250#, 420#)
    
    '座標値取得
    Set mPnts = KCL.InitLst()
    mPnts.Add p1
    
    Call Get_KochCurvePos(p1, p2, LEVEL)
    Call Get_KochCurvePos(p2, p3, LEVEL)
    Call Get_KochCurvePos(p3, p1, LEVEL)
    
    '座標値→点ﾘﾌｧﾚﾝｽ
    Dim Refs As Object
    Set Refs = Get_PointRefs(mPnts)
    
    '折れ線化
    Dim Poly  As HybridShapePolyline
    Set Poly = Init_Poly(Refs)
    
    '形状ｾｯﾄへ挿入
    Dim Hbdy As HybridBody
    Set Hbdy = mPt.hybridBodies.Add()
    Hbdy.Name = "Koch_Curve"
    
    Hbdy.AppendHybridShape Poly
    
    'Refsの最後の点のみ不要
    mFact.DeleteObjectForDatum Refs(Refs.Count - 1)
    
    '終わり
    MsgBox "Done"
End Sub

'ﾘﾌｧﾚﾝｽﾘｽﾄから折れ線生成
Private Function Init_Poly(ByVal Refs As Object) As HybridShapePolyline
    Dim Poly As HybridShapePolyline
    Set Poly = mFact.AddNewPolyline()
    
    Dim i As Long
    For i = 0 To Refs.Count - 2
        Poly.InsertElement Refs(i), i
    Next
    Poly.Closure = True
    mPt.UpdateObject Poly
    
    Set Init_Poly = Poly
End Function

'xy座標値郡から点のﾘﾌｧﾚﾝｽﾘｽﾄ生成
Private Function Get_PointRefs(ByVal Lst As Object) As Object
    Dim Refs As Object
    Set Refs = KCL.InitLst
    
    Dim p As Variant
    For Each p In mPnts
        Refs.Add Init_PointRef(p)
    Next
    
    Set Get_PointRefs = Refs
End Function

'xy座標値から点のﾘﾌｧﾚﾝｽ生成
Private Function Init_PointRef(ByVal Ary As Variant) As Reference
    Dim p As HybridShapePointCoord
    Set p = mFact.AddNewPointCoord(Ary(0), Ary(1), 0#)
    mPt.UpdateObject p
    
    Set Init_PointRef = mPt.CreateReferenceFromObject(p)
End Function

'ｺｯﾎ曲線座標
Private Sub Get_KochCurvePos(ByVal p1 As Variant, ByVal p2 As Variant, lv As Long)
    Dim p3 As Variant, p4 As Variant, p5 As Variant
    p3 = Array((2 * p1(0) + p2(0)) * m1_3, (2 * p1(1) + p2(1)) * m1_3)
    p4 = Array((p1(0) + 2 * p2(0)) * m1_3, (p1(1) + 2 * p2(1)) * m1_3)
    
    Dim xx As Double, yy As Double
    xx = p2(0) - p1(0)
    yy = -(p2(1) - p1(1))
    
    Dim dist As Double
    dist = Sqr(xx * xx + yy * yy) * m1_Sq3
    
    Dim ang As Double
    If xx >= 0 Then
        ang = Atn(yy / xx) + mPI_6
        p5 = Array(p1(0) + (dist * Cos(ang)), p1(1) - (dist * Sin(ang)))
    Else
        ang = Atn(yy / xx) - mPI_6
        p5 = Array(p2(0) + (dist * Cos(ang)), p2(1) - (dist * Sin(ang)))
    End If
    
    If lv < 1 Then
        mPnts.Add p3
        mPnts.Add p5
        mPnts.Add p4
        mPnts.Add p2
    Else
        Call Get_KochCurvePos(p1, p3, lv - 1)
        Call Get_KochCurvePos(p3, p5, lv - 1)
        Call Get_KochCurvePos(p5, p4, lv - 1)
        Call Get_KochCurvePos(p4, p2, lv - 1)
    End If
End Sub

再帰でやるのもどうかな？　とも思ったのですが、再帰の為の記事だったので
再帰のままです。

元の記事では、座標値を計算しながら線を描いてますが、
まとめて座標値を取得し、一本一本描かずに折れ線化しています。
(他にも計算ｺｽﾄの高そうな部分は、予めﾒﾝﾊﾞ変数化し計算量を減らしてます)

円を指定して内接するようにしようかとも思いましたが、
利用価値が低そうなので、単にXY平面に描くだけにしました。

見ていたら雪の結晶を思い出し、よけいに寒くなりました･･･。

背景色を変更・復元する2

こちらの続きです。
背景色を変更・復元する - C#ATIA

"ﾊﾟﾗﾒｰﾀを作成するのに処理時間がかかる" との事でしたので、
代案として、XY平面に元の背景色をﾊﾞｯｸｱｯﾌﾟする事にしました。

又、Formのﾎﾞﾀﾝで操作可能なもののｻﾝﾌﾟﾙにして見ました。

まず、新作したFormにｺﾏﾝﾄﾞﾎﾞﾀﾝを2つ配置します。
それぞれの名前はそのままなのですが、念の為記載しておきます。
・UserForm1
・CommandButton1
・CommandButton2

このﾌｫｰﾑのｺｰﾄﾞ部分に以下のｺｰﾄﾞを貼り付けます。

'vba sample_ChangeBackColor ver0.0.2 by Kantoku
'CATIAの背景色を変更・復元
Option Explicit

'ﾒﾝﾊﾞ変数
Dim mDoc As PartDocument
Dim mPt As Part
Dim mSel As Selection
Dim mVis As VisPropertySet
Dim mVisSetAtt As VisualizationSettingAtt
Dim mBackColor As Variant

Private Sub UserForm_Initialize()
    'Form設定
    Me.CommandButton1.Caption = "背景色-白"
    Me.CommandButton2.Caption = "背景色-復元"
    
    '一時的な背景色
    mBackColor = Array(255, 255, 255)
    
    'CATIA情報
    Set mDoc = CATIA.ActiveDocument
    Set mPt = mDoc.Part
    Set mSel = mDoc.Selection
    Set mVis = mSel.VisProperties
    Set mVisSetAtt = CATIA.SettingControllers.Item( _
        "CATVizVisualizationSettingCtrl")
End Sub

'ｺﾏﾝﾄﾞﾎﾞﾀﾝ1
Private Sub CommandButton1_Click()
    Call ChangeBackColor
End Sub

'ｺﾏﾝﾄﾞﾎﾞﾀﾝ2
Private Sub CommandButton2_Click()
    Call RestorationBackColor
End Sub

' --- ｻﾎﾟｰﾄ関数 ---

'BACKCOLORに変更
Private Sub ChangeBackColor()
    Dim Color As Variant
    
    '背景色取得
    Color = Get_BackRGB()
    
    'XY平面に割り当て
    Call Set_PlaneRGB(mPt.OriginElements.PlaneXY, Color)
    
    '背景色変更
    Call Set_BackRGB(mBackColor)
End Sub

'復元
Sub RestorationBackColor()
    Dim Color As Variant
    
    'XY平面色取得
    Color = Get_PlaneRGB(mPt.OriginElements.PlaneXY)
    
    '背景色復元
    Call Set_BackRGB(Color)
    
    'YZ平面色取得
    Color = Get_PlaneRGB(mPt.OriginElements.PlaneYZ)
    
    'XY平面色復元
    Call Set_PlaneRGB(mPt.OriginElements.PlaneXY, Color)
End Sub

Private Function Set_PlaneRGB(ByVal Plane As Plane, _
                              ByVal Color As Variant)
    mSel.Clear
    mSel.Add Plane
    
    mVis.SetRealColor Color(0), Color(1), Color(2), 1
    mSel.Clear
End Function

Private Function Get_PlaneRGB(ByVal Plane As Plane)
    mSel.Clear
    mSel.Add Plane
    
    Dim Color(2) As Long
    mVis.GetRealColor Color(0), Color(1), Color(2)
    mSel.Clear
    Get_PlaneRGB = Color
End Function

Private Sub Set_BackRGB(ByVal Color As Variant)
    Call mVisSetAtt.SetBackgroundRGB( _
        Color(0), Color(1), Color(2))
    mVisSetAtt.SaveRepository
End Sub

Private Function Get_BackRGB() As Variant
    Dim Color(2) As Long
    Call mVisSetAtt.GetBackgroundRGB( _
        Color(0), Color(1), Color(2))
    Get_BackRGB = Color
End Function

"例外処理は要らない" との事なので、ほぼしておりません。
念の為、
・PartDocument以外はｴﾗｰになります。
・背景色復元後、XY平面色も復元させていますが、
　その際YZ平面色をXY平面に反映させています。(通常同じだろうと･･･)
・2度続けて、"背景色-白" ﾎﾞﾀﾝを押すと、復元不可能になります。

StartCommandとRefreshDisplay

別のものを作成しているうちに気が付いたので覚書なのですが、
ひょっとしたら既出なのかも知れません。

CATIAのﾏｸﾛでは、全てのｺﾏﾝﾄﾞ類を実行する為の関数類が提供されて
いるわけではないのですが、

CATIA.StartCommand xxxx(ｺﾏﾝﾄﾞ文字列)

を利用すると、手動での実行時のﾀﾞｲｱﾛｸﾞが出現する為、不可能と
思われたことが可能になる場合が有ります。
こちらで作成したｼﾙｴｯﾄｺﾏﾝﾄﾞの無意味なｻﾝﾌﾟﾙも、そんな方法です。
ｼﾙｴｯﾄ(事前選択+CATIA.StartCommand) - C#ATIA

但し、困るのは "StartCommand" は、ﾀﾞｲｱﾛｸﾞを呼び出してくれる
だけなので、"事前選択" と "SendKeys" を利用する事になります。
･･･が、"SendKeys"　がﾅｶﾅｶの曲者で、思ったようなﾀｲﾐﾝｸﾞでは
文字を送ってくれないです。

そんな例として、一つ。
手動の場合は事前に面を選択し形状ｾｯﾄを作ると、子の要素として
取り入れた状態で、形状ｾｯﾄが新たに作成されます。
言葉では伝わりにくいので、こんな感じの操作です。

　
形状ｾｯﾄを作る為の関数は用意されているのですが、子の要素を
取り入れながら形状ｾｯﾄ新たに作成する関数は存在していないです。
恐らく。
こう言った場合、"StartCommand" を利用する以外には方法が無さ
そうなので、こんな感じのｺｰﾄﾞを作成しました。

'vba これNGです using-'KCL0.0.12'
'選択した要素を子とする形状ｾｯﾄを作成

'ｺﾏﾝﾄﾞ文字列
Private Const CMD = "形状ｾｯﾄ..."

Sub CATMain()
    Dim Shp As HybridShape
    Set Shp = KCL.SelectItem("GSD要素を選択", "HybridShape")
    If Shp Is Nothing Then Exit Sub
    
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    
    Sel.Clear
    Sel.Add Shp
    
    CATIA.StartCommand CMD
    SendKeys "{Enter}", True
End Sub

子の要素を選択状態のまま、形状ｾｯﾄを作成するｺﾏﾝﾄﾞを呼び出し、
最後にEnterｷｰを投げています。
悪くもない感じがするのですが、実際に実行してみるとこのような
ﾀﾞｲｱﾛｸﾞが表示された状態で終わってしまします。

    SendKeys "{Enter}", True

の部分が上手く行ってないです。
こんな感じのものや
http://www.geocities.co.jp/SiliconValley-PaloAlto/9180/exsendkeys.html
ｳｪｲﾄさせたりしても変化無しでした。

試していて感じたのは、ﾀﾞｲｱﾛｸﾞが表示されるのが遅いのではなく、
ﾏｸﾛの処理を待った上で、ﾀﾞｲｱﾛｸﾞが表示されるような気さえします。

そこでこんな感じ1行追加しただけで、上手く行くようになりました。

'vba sample_Init_HybridBody_InsItem_ver0.0.1  using-'KCL0.0.12'  by Kantoku
'選択した要素を子とする形状ｾｯﾄを作成

'ｺﾏﾝﾄﾞ文字列
Private Const CMD = "形状ｾｯﾄ..."

Sub CATMain()
    Dim Shp As HybridShape
    Set Shp = KCL.SelectItem("GSD要素を選択", "HybridShape")
    If Shp Is Nothing Then Exit Sub
    
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    
    Sel.Clear
    Sel.Add Shp
    
    CATIA.StartCommand CMD
    CATIA.RefreshDisplay = True '追加
    SendKeys "{Enter}", True
End Sub

RefreshDisplayを間に挟んだところ、Enterｷｰを認識してくれました。

単に画面の更新を入れるだけで、良かったみたいです。
少しだけ "StartCommand" の利用する場面が増えそうな気がします。
本当は、 "形状ｾｯﾄの変更" をやりたいんですけどね。

背景色を変更・復元する

ﾀｲﾄﾙが異なりますが、こちらの続きです。
画面ｷｬﾌﾟﾁｬをｸﾘｯﾌﾟﾎﾞｰﾄﾞに保存する - C#ATIA

単に背景色を切り替えるﾏｸﾛです。
但し元の背景色に復元出来る様に、変更前の背景色RGBをﾊﾟﾗﾒｰﾀに
保存しています。
(外部ﾌｧｲﾙや何処かのﾌﾟﾛﾊﾟﾃｨに書き出すより、自然かと思います)

'vba sample_ChangeBackColor ver0.0.1 by Kantoku
'CATIAの背景色を変更・復元

Option Explicit

'背景色をﾊﾞｯｸｱｯﾌﾟするﾊﾟﾗﾒｰﾀ名
Private Const BACKCOLOR_PRAM_NAME = "BackColorRGB"

'変更後背景色
Private Const BACKCOLOR = "255,255,255"

Sub CATMain()
    Dim Doc As Document
    Set Doc = CATIA.ActiveDocument
    
    Dim Msg As String
    
    Dim Prms As Parameters
    Set Prms = Get_Prms(Doc)
    If Prms Is Nothing Then
        Msg = "ProductかPartで使用してください"
        MsgBox Msg
        Exit Sub
    End If
    
    Msg = "背景色を変更しますか?" & vbNewLine & _
        "はい : 背景色を変更(RGB:" & BACKCOLOR & ")" & vbNewLine & _
        "いいえ : ﾊﾞｯｸｱｯﾌﾟしている背景色に復元" & vbNewLine & _
        "ｷｬﾝｾﾙ : 中止"
            
    Select Case MsgBox(Msg, vbYesNoCancel + vbQuestion)
        Case vbYes
            Call ChangeBackColor(Prms) '白に変更
        Case vbNo
            Call RestorationBackColor(Prms) '復元
        Case Else
            Exit Sub
    End Select
    
End Sub

'復元
Sub RestorationBackColor(ByVal Prms As Parameters)
    Dim Msg As String
    
    If Not Is_ExistsPrm(Prms, BACKCOLOR_PRAM_NAME) Then
        Msg = "ﾊﾞｯｸｱｯﾌﾟしている背景色が有りませんでした"
        MsgBox Msg, vbOKOnly + vbExclamation
        Exit Sub
    End If
    
    Dim Prm As StrParam
    Set Prm = Prms.Item(BACKCOLOR_PRAM_NAME)
    
    If Not Is_RGB_Str(Prm.Value) Then
        Msg = "ﾊﾞｯｸｱｯﾌﾟしている背景色ﾊﾟﾗﾒｰﾀが不正です"
        MsgBox Msg, vbOKOnly + vbExclamation
        Exit Sub
    End If
    
    Call Update_BackRGB(Prm.Value)
    
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    With Sel
        .Clear
        .Add Prm
        .Delete
    End With
End Sub

'BACKCOLORに変更
Private Sub ChangeBackColor(ByVal Prms As Parameters)
    Dim Msg As String
    
    Dim Prm As StrParam
    If Is_ExistsPrm(Prms, BACKCOLOR_PRAM_NAME) Then
        Set Prm = Prms.Item(BACKCOLOR_PRAM_NAME)
        
        Msg = "既に背景色のﾊﾞｯｸｱｯﾌﾟがありますが、" & _
            "作業を続けますか?" & vbNewLine & _
            "はい : 新たにﾊﾞｯｸｱｯﾌﾟし、作業を進める" & vbNewLine & _
            "いいえ : ﾊﾞｯｸｱｯﾌﾟは変更せず、作業を進める" & vbNewLine & _
            "ｷｬﾝｾﾙ : 中止"
            
        Select Case MsgBox(Msg, vbYesNoCancel + vbQuestion)
            Case vbYes
                Prm.Value = Get_BackRGB_ToStr()
            Case vbNo
                '何もしない
            Case Else
                Exit Sub
        End Select
    Else
        Set Prm = Prms.CreateString(BACKCOLOR_PRAM_NAME, "")
        Prm.Value = Get_BackRGB_ToStr()
    End If
    
    Call Update_BackRGB(BACKCOLOR)
    'Prm.Hidden = True '非表示
End Sub


' --- ｻﾎﾟｰﾄ関数 ---
Private Function Is_RGB_Str(ByVal Str As String) As Boolean
    Is_RGB_Str = False
    
    Dim Ary As Variant
    Ary = Split(Str, ",")
    If Not UBound(Ary) = 2 Then Exit Function
    
    Dim i As Long
    For i = 0 To 2
        If Not IsNumeric(Ary(i)) Then Exit Function
        If Not Ary(i) = CLng(Ary(i)) Then Exit Function
    Next
    
    Is_RGB_Str = True
End Function

Private Sub Update_BackRGB(ByVal RGB_Str As String)
    Dim VisSetAtt As VisualizationSettingAtt
    Set VisSetAtt = CATIA.SettingControllers.Item( _
        "CATVizVisualizationSettingCtrl")
        
    Dim Rgb As Variant
    Rgb = Split(RGB_Str, ",")

    Call VisSetAtt.SetBackgroundRGB(Rgb(0), Rgb(1), Rgb(2))
    VisSetAtt.SaveRepository
End Sub

Private Function Get_BackRGB_ToStr() As String
    Dim VisSetAtt As VisualizationSettingAtt
    Set VisSetAtt = CATIA.SettingControllers.Item( _
        "CATVizVisualizationSettingCtrl")
    
    Dim ActColor(2) As Long
    Call VisSetAtt.GetBackgroundRGB( _
        ActColor(0), ActColor(1), ActColor(2))
    
    Get_BackRGB_ToStr = Join( _
        Array(ActColor(0), ActColor(1), ActColor(2)), ",")
End Function

Private Function Init_Prm(ByVal Prms As Parameters, _
                          ByVal Name As String) As Parameter
    Set Init_Prm = Prms.CreateString(BACKCOLOR_PRAM_NAME, "")
End Function

Private Function Is_ExistsPrm(ByVal Prms As Parameters, _
                              ByVal Name As String) As Boolean
    Dim Prm As Parameter
    
    On Error Resume Next
        Set Prm = Prms.Item(Name)
    On Error GoTo 0
    
    Is_ExistsPrm = Not (Prm Is Nothing)
    
    If Not TypeName(Prm) = "StrParam" Then
        Is_ExistsPrm = False
        '文字型ﾀｲﾌﾟじゃない同一名のﾊﾟﾗﾒｰﾀがある- 未対応
    End If
End Function

Private Function Get_Prms(ByVal Doc As Document) As Parameters
    Set Get_Prms = Nothing
    Select Case TypeName(Doc)
        Case "ProductDocument"
            Set Get_Prms = Doc.Product.Parameters
        Case "PartDocument"
            Set Get_Prms = Doc.Part.Parameters
    End Select
End Function

定数 "BACKCOLOR_PRAM_NAME" と同一名の文字型以外のﾊﾟﾗﾒｰﾀが存在していると
上手く行かないです･･･。(対応策を深く考えませんでした)

又、KCLを利用しなかったのでDocumentのﾁｪｯｸがやや甘めです。

変更・復元を一つのﾏｸﾛ(最初のMsgboxで切り替え)で行っている為、
使い勝手がｲﾏｲﾁなのですが、ﾌﾞﾛｸﾞでFormのｺｰﾄﾞをUp出来ないので
ご勘弁を。

正直な所、このようなﾏｸﾛよりｷｬﾌﾟﾁｬをｼﾞｬﾝｼﾞｬﾝ作るﾏｸﾛの方が、
効率が良い気がするのですが･･･。

例えば、ﾃﾞｰﾀをｽﾞｰﾑ・ｽﾋﾟﾝさせながら、ｽﾍﾟｰｽｷｰを押すたびに
ｷｬﾌﾟﾁｬﾌｧｲﾙを作る　とか、
ｽﾍﾟｰｽｷｰを押すたびにExcelにｷｬﾌﾟﾁｬを貼り付けるとか･･･。
(当方Excelが古いため試せませんが、ひょっとしたらCATIAから
Excel操作できるのかな?)