MyRibbonTools T02_GetSetSht

Option Explicit
'*******************************************************
'    ■ アクティブシートの色をテーマカラーから切り離す
'    ・背景色・文字色・罫線色をRGB値で固定化
'    ・図形の塗りつぶし・枠線・フォントもRGBで固定
'    ・テーマ変更による色の変化を防止
'    ・テーブルスタイルは別プロシージャで複製し、Callで呼び出す
'*******************************************************
Sub FixColorsAgainstThemeChange()

    Dim rng As Range
    Dim tgtCell As Range
    Dim tgtBorder As Border
    Dim shp As Shape

    'アクティブシートの使用範囲を取得
    Set rng = ActiveSheet.UsedRange

    '各セルの色を固定化（テーマに依存しないRGB値へ）
    For Each tgtCell In rng
        'テーブル内のセルでない場合のみ処理
        If tgtCell.ListObject Is Nothing Then
            '背景色を固定（RGB値として再設定）
            tgtCell.Interior.Color = tgtCell.Interior.Color

            '文字色を固定
            tgtCell.Font.Color = tgtCell.Font.Color

            '罫線色を固定（各方向に対して）
            For Each tgtBorder In tgtCell.Borders
                If tgtBorder.LineStyle <> xlLineStyleNone Then
                    tgtBorder.Color = tgtBorder.Color   '罫線色を固定化
                End If
            Next tgtBorder
        End If
    Next tgtCell

    '図形の色・枠線・フォントを固定化
    For Each shp In ActiveSheet.Shapes
        With shp
            '背景色（塗りつぶし）を固定
            If .Fill.Visible Then
                .Fill.ForeColor.RGB = .Fill.ForeColor.RGB
            End If

            '枠線色を固定
            If .line.Visible Then
                .line.ForeColor.RGB = .line.ForeColor.RGB
            End If
            
            '一時的にエラー無視
            On Error Resume Next
            '図形内の文字色・フォントを固定
            If .TextFrame2.hasText Then
                With .TextFrame2.TextRange.Font
                    .Fill.ForeColor.RGB = .Fill.ForeColor.RGB
                    .Name = .Name
                    .Size = .Size
                    .Bold = .Bold
                    .Italic = .Italic
                End With
            End If
            'エラーハンドリング解除
            On Error GoTo 0
            
        End With
    Next shp
    
    'テーブルスタイルをRGBで固定化（別プロシージャを呼び出し）
    Call DuplicateActiveSheetTableStylesAsFixedRGB

End Sub

'*******************************************************
'    ■ アクティブシートのテーブルスタイルをRGB値で複製・再適用
'    ・既存のテーブルスタイルを複製し、背景色・文字色・罫線色をRGB値で固定化
'    ・テーマカラー依存を排除し、テーマ変更による色の変化を防止
'    ・複製済みスタイルは Dictionary で記録し、再利用
'    ・スタイル分類（淡色1～7／淡色8～21／中間／濃色／なし）に応じて文字色を設定
'*******************************************************
Public Sub DuplicateActiveSheetTableStylesAsFixedRGB()

    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim baseStyle As TableStyle
    Dim newStyle As TableStyle
    Dim elementType As Variant
    Dim borderType As Variant
    Dim elementSource As TableStyleElement
    Dim elementTarget As TableStyleElement
    Dim styleName As String
    Dim styleIndex As Long
    Dim styleMap As Scripting.Dictionary
    Dim styleNameExists As Boolean
    Dim elementTypes As Variant
    Dim borderTypes As Variant
    Dim styleNameRaw As String
    Dim isLight1to7 As Boolean
    Dim isLight8to21 As Boolean
    Dim isMediumOrDark As Boolean
    Dim isNone As Boolean
    Dim srcLineStyle As Variant

    '▼ 初期化
    Set ws = ActiveSheet
    Set styleMap = New Scripting.Dictionary
    styleIndex = 1

    '▼ アクティブシート内のすべてのテーブルに対して処理
    For Each tbl In ws.ListObjects

        '▼ 自作スタイル（MyTblStyle*）はスキップ
        If tbl.TableStyle Like "MyTblStyle*" Then GoTo SkipTable

        '▼ 元スタイルを取得
        On Error Resume Next
        Set baseStyle = ActiveWorkbook.TableStyles(tbl.TableStyle)
        On Error GoTo 0
        If baseStyle Is Nothing Then GoTo SkipTable

        '▼ すでに複製済みなら再利用
        If styleMap.Exists(baseStyle.Name) Then
            tbl.TableStyle = styleMap(baseStyle.Name)
            GoTo SkipTable
        End If

        '▼ 新スタイル名を生成（MyTblStyle1, 2, 3...）
        Do
            styleName = "MyTblStyle" & styleIndex
            styleNameExists = StyleExists(styleName)
            styleIndex = styleIndex + 1
        Loop While styleNameExists

        '▼ 新スタイル作成
        Set newStyle = ActiveWorkbook.TableStyles.Add(styleName)
        newStyle.ShowAsAvailableTableStyle = True
        styleMap.Add baseStyle.Name, styleName

        '▼ コピー対象のスタイル要素（全体・ヘッダー・列・行など）
        elementTypes = Array( _
            xlWholeTable, xlHeaderRow, xlFirstColumn, xlLastColumn, _
            xlTotalRow, xlRowStripe1, xlRowStripe2)

        For Each elementType In elementTypes
            Set elementSource = baseStyle.TableStyleElements(elementType)
            Set elementTarget = newStyle.TableStyleElements(elementType)

            '▼ 背景色をRGB値で固定（Color優先、ThemeColorは変換）
            With elementSource.Interior
                If .Color <> 0 Then
                    elementTarget.Interior.Color = .Color
                ElseIf .ThemeColor <> -1 Then
                    elementTarget.Interior.Color = GetRGBFromThemeColor(.ThemeColor, .TintAndShade)
                End If
            End With

            '▼ スタイル分類を判定
            styleNameRaw = baseStyle.Name
            isLight1to7 = (styleNameRaw Like "TableStyleLight[1-7]")
            isLight8to21 = (styleNameRaw Like "TableStyleLight1#" Or styleNameRaw Like "TableStyleLight2#")
            isMediumOrDark = (styleNameRaw Like "TableStyleMedium*" Or styleNameRaw Like "TableStyleDark*")
            isNone = (styleNameRaw = "TableStyleNone")

            '▼ 文字色を分類に応じて設定
            If isLight1to7 Then
                'テーブルスタイル：淡色１～７の場合（テーマカラーをRGBに変換）
                With elementSource.Font
                    If .Color <> 0 Then
                        elementTarget.Font.Color = .Color
                    ElseIf .ThemeColor <> -1 Then
                        elementTarget.Font.Color = GetRGBFromThemeColor(.ThemeColor, .TintAndShade)
                    End If
                End With
            ElseIf isLight8to21 Or isMediumOrDark Then
                'テーブルスタイル：淡色８～２１、中間、濃色の場合
                If elementType = xlHeaderRow Then
                    elementTarget.Font.Color = vbWhite
                Else
                    elementTarget.Font.Color = vbBlack
                End If
            ElseIf isNone Then
                'テーブルスタイル：「なし」の場合
                elementTarget.Font.Color = vbBlack
            End If

            '▼ 罫線をRGBで固定（上下左右＋内側）
            borderTypes = Array( _
                xlEdgeTop, xlEdgeBottom, xlEdgeLeft, xlEdgeRight, _
                xlInsideHorizontal, xlInsideVertical)

            For Each borderType In borderTypes
                On Error Resume Next
                srcLineStyle = elementSource.Borders(borderType).LineStyle
                If Not IsEmpty(srcLineStyle) And srcLineStyle <> xlLineStyleNone Then
                    With elementTarget.Borders(borderType)
                        .Color = elementSource.Borders(borderType).Color
                        .LineStyle = srcLineStyle
                        .Weight = elementSource.Borders(borderType).Weight
                    End With
                End If
                On Error GoTo 0
            Next borderType
        Next elementType

        '▼ 新スタイルをテーブルに適用
        tbl.TableStyle = styleName
        Debug.Print tbl.Name & " → " & styleName

SkipTable:
    Next tbl

End Sub
'+++*********************************************************+++
'  テーマカラーと TintAndShade を RGB に変換する補助関数
'  一時セルに色を適用して .Color を取得
'+++*********************************************************+++
Private Function GetRGBFromThemeColor(themeColorIndex As Long, tintValue As Double) As Long
    Dim tempCell As Range
    Set tempCell = ActiveSheet.Cells(1, Columns.Count)
    With tempCell.Interior
        .ThemeColor = themeColorIndex
        .TintAndShade = tintValue
    End With
    GetRGBFromThemeColor = tempCell.Interior.Color
    tempCell.Interior.ColorIndex = xlColorIndexNone
End Function
'+++*********************************************************+++
' スタイル名がすでに存在するか確認する関数
'+++*********************************************************+++
Private Function StyleExists(styleName As String) As Boolean
    Dim s As TableStyle
    On Error Resume Next
    Set s = ActiveWorkbook.TableStyles(styleName)
    StyleExists = Not s Is Nothing
    On Error GoTo 0
End Function