C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA(最近はPMillマクロとFusion360APIが多い)

背景色を変更・復元する

タイトルが異なりますが、こちらの続きです。
画面キャプチャをクリップボードに保存する - 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操作できるのかな?)