Template_M13_ThemeColor

Option Explicit

'*****************************************************
'    アクティブブックのテーマを取得
'*****************************************************
Sub getTheme()

    Dim i As Long
    Dim j As Long
    Dim setRow As Long
    Dim setRow2 As Long
    Dim setCol As Long
    Dim x() As Variant
    
    x = Array(0, 0, 0.8, 0.6, 0.4, -0.25, -0.5)
 
    setRow = 8
    setRow2 = 18
    setCol = 4
    
    Call StopUpdating

    With ThisWorkbook.Worksheets("テーマ設定")
        .Select    '必須
        For i = 1 To 6
            For j = 1 To 12
                With .Cells(i + setRow, j + setCol).Interior
                    .ThemeColor = j
                    .TintAndShade = x(i)
                End With
            Next j
        Next i
        For i = 1 To 6
            For j = 1 To 12
                .Cells(i + setRow, j + setCol).Value = .Cells(i + setRow, j + setCol).Interior.Color
                .Cells(i + setRow2, j + setCol).Interior.Color = .Cells(i + setRow, j + setCol).Value
            Next j
        Next i
    End With
    With ActiveWorkbook.Theme.ThemeFontScheme
        Cells(19, 3) = .MajorFont(1).Name
        Cells(20, 3) = .MinorFont(1).Name
        Cells(22, 3) = .MajorFont(3).Name
        Cells(23, 3) = .MinorFont(3).Name
    End With
    Call Updating

End Sub

'*****************************************************
'    アクティブブックのテーマに指定のカラー等を設定
'*****************************************************
Sub SetThemeColor()

    Dim i As Long
    Dim j As Long
    Dim setRow As Long
    Dim setRow2 As Long
    Dim setCol As Long
    Dim x() As Variant
    Dim y() As Variant
    Dim tgtRng As Range
    Dim myC As Range
    
    Dim tfThemeFont As ThemeFont
    
    Call StopUpdating
    
    x = Array(0, 0, 0.8, 0.6, 0.4, -0.25, -0.5)
    'テーマカラーの出力順の設定 (最初の0は調整用)
    y = Array(0, 2, 1, 4, 3, 5, 6, 7, 8, 9, 10, 11, 12)
    
    setRow = 8
    setRow2 = 18
    setCol = 4
    
    With ThisWorkbook.Worksheets("テーマ設定")
 
        .Select     '必須ののselect
        For j = 1 To 12
            '9行目で取得
            ActiveWorkbook.Theme.ThemeColorScheme.Colors(j) = .Cells(9, y(j) + setCol)
        Next j
        .Columns("E:P").ColumnWidth = 8
        For i = 1 To 6
        
            For j = 1 To 12
                With .Cells(i + setRow, j + setCol).Interior
                    .ThemeColor = j
                    .TintAndShade = x(i)
                End With
                .Cells(i + setRow, j + setCol).Value = _
                    .Cells(i + setRow, j + setCol).Interior.Color
            Next j

            For j = 1 To 12
                With .Cells(i + setRow2, j + setCol).Interior
                    .ThemeColor = j
                    .TintAndShade = x(i)
                End With
            Next j
        Next i

        With ActiveWorkbook.Theme.ThemeFontScheme
            If Range("C10").Value <> "" Then
                .MajorFont(1) = Range("C10").Value      '見出し 英数字 設定
            End If
            If Range("C11").Value <> "" Then
                .MinorFont(1) = Range("C11").Value      '本文   英数字 設定
            End If
            If Range("C13").Value <> "" Then
                .MajorFont(3) = Range("C13").Value      '見出し 日本語 設定
            End If
            If Range("C14").Value <> "" Then
                .MinorFont(3) = Range("C14").Value      '本文　 日本語 設定
            End If

            Range("C19").Value = .MajorFont(1).Name
            Range("C19").Font.Name = .MajorFont(1).Name
            Range("C20").Value = .MinorFont(1).Name
            Range("C20").Font.Name = .MinorFont(1).Name
            
            Range("C22").Value = .MajorFont(3).Name
            Range("C22").Font.Name = .MajorFont(3).Name
            Range("C23").Value = .MinorFont(3).Name
            Range("C23").Font.Name = .MinorFont(3).Name
            
        End With
        .Range("E9:P14").Font.Name = .Range("C19").Value
        
        Set tgtRng = .Range("E9:P14")
        For Each myC In tgtRng
            Call AdjustFontColor(myC)
        Next myC
        Set tgtRng = Nothing
        '■スクロールして先頭に移動する
        Application.Goto reference:=.Range("A1"), Scroll:=True
        .Cells(1, 1).Select
    End With
    Call Updating
End Sub

'*****************************************************
'    アクティブブックのテーマカラー確認
'*****************************************************
Sub ChkThemeColor()
    Dim j As Long
    For j = 1 To 12
        Debug.Print ActiveWorkbook.Theme.ThemeColorScheme.Colors(j)
    Next j
End Sub

'*****************************************************
'    アクティブブックのフォント確認
'*****************************************************
Sub ChkFont()

    Dim i As Long
    Dim MaxRow As Long
    With ThisWorkbook.Worksheets("フォント検証")
        MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To MaxRow
             If .Cells(i, 1) <> "" Then
                .Cells(i, 1).Font.Name = .Cells(i, 1)
                .Cells(i, 2).Font.Name = .Cells(i, 1)
                .Cells(i, 3).Font.Name = .Cells(i, 1)
            End If
        Next i
    End With

End Sub

'*****************************************************
'    アクティブブック、セル フォント取得
'*****************************************************
Public Sub GetFontColor()
    With ActiveWorkbook.Theme.ThemeFontScheme
        Debug.Print "MajorFont：" & .MajorFont(1).Name
        Debug.Print "フォント名：" & ActiveCell.Font.Name
    End With
End Sub

'+++*****************************************************+++
'    【テーマ設定】シートを作成
'+++*****************************************************+++
Sub MakeSetSht()

    Dim i As Long
    Dim j As Long
    Dim IngColor As Long
    Dim rHeight() As Variant
    Dim cWidth() As Variant
    Dim strAry1() As Variant
    Dim strAry2() As Variant
    Dim strAry3() As Variant
    Dim strAry4() As Variant

    Dim SetThemeSht As Worksheet
    Dim shp As Shape
    
    Const TTLITRCOLOR As Long = 16229988      '薄めの青
    Const BARITRCOLOR As Long = 15890709      '濃いめの青
    Const TCOLOR As Long = 16249582           'ライグレー
    Const LINECOLOR As Long = 15326159        'ライトブルーグレー
    
    rHeight = Array(0, 5, 25, 1.8, 3, 5.5, 29, 16, 4, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16)
    cWidth = Array(0, 0.5, 11.4, 12.87, 0.5, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 0.5)
    
    strAry1 = Array("", "設定範囲", "", "フォント パターン", "見出し 英数字", "本文   英数字", _
            "", "見出し 日本語", "本文   日本語", "", "", "フォント パターン", "", _
            "見出し 英数字", "本文   英数字", "", "見出し 日本語", "本文   日本語")
    strAry2 = Array("", "色番号記入  ⇒", "", "", "", "", _
            "", "", "", "現在のテーマ")
    strAry3 = Array("", "背景1", "テキスト１", "背景２", "テキスト２", _
            "アクセント１", "アクセント2", "アクセント3", "アクセント4", "アクセント5", _
            "アクセント6", "ハイパーリンク", "表示済みのハイパーリンク")
    strAry4 = Array(0, 2, 1, 4, 3, 5, 6, 7, 8, 9, 10, 11, 12)

    Call StopUpdating
    
    If IsSht("テーマ設定") = False Then
        Worksheets.Add After:=ActiveSheet
        ActiveSheet.Name = "テーマ設定"
    Else
        With ThisWorkbook.Worksheets("テーマ設定")
            'エラーを無視
            On Error Resume Next
            .Cells.Clear
            For Each shp In ActiveSheet.Shapes
                shp.Delete '図形を削除
            Next
            ActiveWindow.FreezePanes = False
            'エラー制御を戻す
            On Error GoTo 0
        End With
    End If
    
    Set SetThemeSht = ThisWorkbook.Worksheets("テーマ設定")
    With SetThemeSht
        .Select
        
        For i = 1 To UBound(rHeight)
            .Rows(i).RowHeight = rHeight(i)
        Next i

        For i = 1 To UBound(cWidth)
            .Columns(i).ColumnWidth = cWidth(i)
        Next i
        .Range("B2:Q2").Interior.Color = TTLITRCOLOR
        .Range("B4:Q4").Interior.Color = BARITRCOLOR
    
        With .Cells.Font
            .Name = "Meiryo UI"
            .Size = 10
            .Color = vbBlack
        End With
    
        With .Range("B6:Q30")
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlCenter
            .ShrinkToFit = True
        End With
        
        With Range("B2")
            .Value = "アクティブブックのテーマ設定"
            .InsertIndent 2
                        
            With .Cells.Font
                .Size = 16
                .Bold = True
                .Color = vbWhite
            End With
        End With
        With Range("E6:P7")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        With .Range("E6:P6")
            .Interior.Color = TCOLOR
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With

        'B列
        For i = 1 To UBound(strAry1)
            .Cells(i + 6, 2) = strAry1(i)
        Next i
        'C列
        For i = 1 To UBound(strAry2)
            .Cells(i + 8, 3) = strAry2(i)
        Next i
        
        '6,7,18行目設定
        For j = 1 To UBound(strAry3)
            .Cells(6, j + 4) = strAry3(j)
            .Cells(7, j + 4) = strAry4(j)
            .Cells(18, j + 4) = strAry3(j)
        Next j
        .Range("B7:C17").Font.Bold = True

        With .Range("C9：C15")
            .Select
            .Font.Color = 15890709      '薄めの青色
            .Font.Bold = True
        End With
        
        'ウィンドウ枠の固定
        ActiveWindow.FreezePanes = True
        'メモリ線非表示
        ActiveWindow.DisplayGridlines = False
        With ActiveSheet.Range("B6")
            ActiveSheet.Shapes.AddShape(Type:=msoShapeRoundedRectangle, _
            Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select
            ActiveSheet.Shapes(1).Name = "設定ボタン"
            '---B6の範囲に、角丸四角形のオートシェイプを作成する
            With Selection.ShapeRange

                .Line.Visible = msoFalse
                With .ThreeD
                    .BevelTopType = msoBevelCircle
                    .BevelTopInset = 6
                    .BevelTopDepth = 6
                    .Depth = 2.5
                End With
                Selection.Text = "設      定"
                With .TextFrame2
                    .TextRange.Font.Bold = msoTrue
                    .VerticalAnchor = msoAnchorMiddle
                    .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                End With
            End With
        End With
        '図形にマクロを登録
        .Shapes(1).OnAction = "SetThemeColor"
        .Cells(1, 1).Select
    End With

    Call Updating
    
End Sub
'*****************************************************
'    いつもの設定 Hint
'*****************************************************
Sub SetMyTheme()
    Dim i As Long
    Dim j As Long
    Dim x() As Variant
    Dim mySet() As Variant
    
    x = Array(0, 0, 0.8, 0.6, 0.4, -0.25, -0.5)
    mySet = Array(0, 16777215, 0, 14139050, 7426101, 14523145, 49407, _
           2674853, 7916552, 13792197, 6369029, 16711680, 12664492)

    '飛行機雲
''    mySet = Array(0,16777215, 0, 14342874, 4539717, 2633439, 1736958, _
''          3522537, 4373377, 11126578, 14457674, 2839536, 5475315)
''    mySet = Array(16777215, 0, 14139050, 7426101, 14523145, 49407, _
''            2674853, 7916552, 10043634, 12664492, 6369092, 16711680)
''    mySet = Array(0,16777215, 0, 14139050, 7426101, 14523145, 49407, _
''           2674853, 7916552, 13792197, 6369029, 16711680, 12664492)

''    Calibri Light
''    Calibri
''    Meiryo UI

''    Century Gothic
''    Meiryo UI

''    Microsoft JhengHei UI
''    UD デジタル 教科書体 NK-B


    
    With ThisWorkbook.Worksheets("テーマ設定")
        .Select
        For j = 1 To 12
            .Cells(9, j + 4) = mySet(j)
        Next j
    End With
 
End Sub