Template_M13_ActiveBookTC

Option Explicit

'+++*****************************************************+++
'    テーマを取得したいブックで実行
'　　QATに設定しておく
'+++*****************************************************+++
Sub getThemeActBook()

    Dim i As Long
    Dim j As Long
    Dim buf As Variant
    Dim x() As Variant
    Dim y() As Variant
    Dim otColorAry() As Variant
    Dim ActBook As Workbook
    Dim ThisBook As Workbook
    Dim tgtSht As Worksheet
    Dim tgtRng As Range
    Dim myC As Range
    Dim wsActive As Worksheet
    Dim tmp As Variant
    Dim ans As Long
    Dim EngMjrFont As String
    Dim EngMnrFont As String
    Dim JpnMjrFont As String
    Dim JpnMnrFont As String

    Const BASEROW As Long = 7
    Const BASEROW2 As Long = 23

    'TintAndShadeの設定 (最初の0は調整用)
    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)
    
    Set ActBook = ActiveWorkbook
    Set ThisBook = ThisWorkbook
    If IsShtOwb("Actブックテーマ", ThisBook.Name) = False Then
        ThisWorkbook.Worksheets.Add After:=ActiveSheet
        ActiveSheet.Name = "Actブックテーマ"
        Call MakeActSht
    End If
    Set wsActive = ThisBook.Worksheets("Actブックテーマ")
    
    
    With ActBook
        If ThisBook.Name <> ActBook.Name Then
            ans = MsgBox("このファイルのテーマを取得します" & vbCrLf & _
                "1番左にシートを追加します" & vbCrLf & _
                "処理を開始してよろしいですか？ ", vbOKCancel, _
                "アクティブブックのテーマ取得")
            
            Select Case ans
                Case vbOK
                    'テーマ取得処理を行う｡
                Case vbCancel
                    MsgBox "キャンセルしました"
                    Exit Sub
            End Select
            '先頭（左側）にシートを追加
            '⇒後で削除するか、保存しないで閉じる
            .Worksheets.Add Before:=.Worksheets(1)
        End If
        
        Set tgtSht = ActiveSheet

        With tgtSht
            .Cells(1, 1) = "こんにちは"
            .Cells(2, 1) = "こんにちは"
            .Cells(1, 1).Font.ThemeFont = xlThemeFontMajor
            .Cells(2, 1).Font.ThemeFont = xlThemeFontMinor
        End With
         
        ReDim otColorAry(1 To 12)
        For i = 1 To 12
             otColorAry(i) = ActBook.Theme.ThemeColorScheme.Colors(i)
             buf = ConvRGB(CLng(otColorAry(i)))
             tmp = Split(buf, ",")
             wsActive.Cells(y(i) + BASEROW, 6).Interior.Color = _
                         RGB(tmp(0), tmp(1), tmp(2))
             wsActive.Cells(y(i) + BASEROW, 7).Value = tmp(0)
             wsActive.Cells(y(i) + BASEROW, 8).Value = tmp(1)
             wsActive.Cells(y(i) + BASEROW, 9).Value = tmp(2)
             wsActive.Cells(y(i) + BASEROW, 10).Value = otColorAry(i)
             wsActive.Cells(y(i) + BASEROW, 11).Value = _
                     "#" & WorksheetFunction.Dec2Hex(otColorAry(i), 6)
             wsActive.Cells(y(i) + BASEROW, 12).Value = _
                     "&H" & WorksheetFunction.Dec2Hex(otColorAry(i), 6)
        Next i
    End With
        
    With ActiveWorkbook.Theme.ThemeFontScheme

        EngMjrFont = .MajorFont(1).Name
        EngMnrFont = .MinorFont(1).Name
        wsActive.Cells(BASEROW2 + 1, 3).Value = EngMjrFont
        wsActive.Cells(BASEROW2 + 2, 3).Value = EngMnrFont
        
        wsActive.Cells(BASEROW2 + 1, 3).Font.Name = EngMjrFont
        wsActive.Cells(BASEROW2 + 2, 3).Font.Name = EngMnrFont
        
        JpnMjrFont = tgtSht.Cells(1, 1).Font.Name
        JpnMnrFont = tgtSht.Cells(2, 1).Font.Name
        wsActive.Cells(BASEROW2 + 3, 3).Value = JpnMjrFont
        wsActive.Cells(BASEROW2 + 4, 3).Value = JpnMnrFont
        
        wsActive.Cells(BASEROW2 + 3, 3).Font.Name = JpnMjrFont
        wsActive.Cells(BASEROW2 + 4, 3).Font.Name = JpnMnrFont
        wsActive.Cells(BASEROW2 + 5, 3).Font.Name = EngMnrFont
        wsActive.Cells(BASEROW2 + 6, 3).Font.Name = JpnMnrFont
    End With
    With ActiveWorkbook.Theme.ThemeFontScheme
        EngMjrFont = .MajorFont(1).Name
        EngMnrFont = .MinorFont(1).Name
        JpnMjrFont = .MajorFont(3).Name
        JpnMnrFont = .MinorFont(3).Name
        wsActive.Cells(BASEROW2 + 1, 3).Value = EngMjrFont
        wsActive.Cells(BASEROW2 + 2, 3).Value = EngMnrFont
        wsActive.Cells(BASEROW2 + 1, 3).Font.Name = EngMjrFont
        wsActive.Cells(BASEROW2 + 2, 3).Font.Name = EngMnrFont
        wsActive.Cells(BASEROW2 + 3, 3).Value = JpnMjrFont
        wsActive.Cells(BASEROW2 + 4, 3).Value = JpnMnrFont
        wsActive.Cells(BASEROW2 + 3, 3).Font.Name = JpnMjrFont
        wsActive.Cells(BASEROW2 + 4, 3).Font.Name = JpnMnrFont
        wsActive.Cells(BASEROW2 + 5, 3).Font.Name = EngMnrFont
        wsActive.Cells(BASEROW2 + 6, 3).Font.Name = JpnMnrFont
    End With
    With wsActive
        For i = 1 To 6
            For j = 1 To 12
                buf = ConvRGB(CLng(otColorAry(j)))
                tmp = Split(buf, ",")
                With .Cells(i + BASEROW2, y(j) + 4).Interior
                    .Color = otColorAry(j)
                    .TintAndShade = x(i)
                    wsActive.Cells(i + BASEROW2, y(j) + 4).Value = .Color
                End With
            Next j
        Next i
        .Range("E21:P22").Font.Name = JpnMnrFont
        .Range("E24:P31").Font.Name = EngMnrFont
        Set tgtRng = .Range("E24:P31")
        For Each myC In tgtRng
            Call AdjustFontColor(myC)
        Next myC
        Set tgtRng = Nothing
    End With
    Erase otColorAry
    ThisBook.Activate
    wsActive.Activate
    Set ThisBook = Nothing
    Set wsActive = Nothing
    Set ActBook = Nothing
    Set tgtSht = Nothing
    MsgBox "完了 ♪"

End Sub

'+++*****************************************************+++
'    背景色によって文字色を白か黒に変更: パターン１
'+++*****************************************************+++
Public Function AdjustFontColor(ByRef myRng As Range)
    Dim myColor As Long
    Dim R As Long
    Dim G As Long
    Dim B As Long
    Dim mySum As Double

    Const MYCOMPCOLOR As Long = 460

    myColor = myRng.Interior.Color
    B = Int(myColor / 65536)
    G = Int((myColor - (B * 65536)) / 256)
    R = myColor - (G * 256) - (B * 65536)
    mySum = R + G + B
    If mySum > MYCOMPCOLOR Then
        myRng.Font.Color = vbBlack   '黒文字に設定
    Else
        myRng.Font.Color = vbWhite   '白文字に設定
    End If
End Function

'+++*****************************************************+++
'    気になるセルを1つ選択して､↓を実行
'    上記 【AdjustFontColor)のMYCOMPCOLORを定めるために使用
'+++*****************************************************+++
Public Sub FontColorChk()

    Dim R As Long
    Dim G As Long
    Dim B As Long
    Dim myColor As Long
    Dim mySum As Double

    myColor = Selection.Interior.Color
    B = Int(myColor / 65536)
    G = Int((myColor - (B * 65536)) / 256)
    R = myColor - (G * 256) - (B * 65536)
    mySum = R + G + B
    Debug.Print mySum

 End Sub

'+++*****************************************************+++
'    背景色によって文字色を白か黒に変更: パターン２
'+++*****************************************************+++
Public Function AdjustFontColor2(ByRef myRng As Range)
    Dim sum As Long
    Dim Index As Long
    Dim myColor As Long

    myColor = myRng.Interior.Color
    For Index = 0 To 2
        sum = sum + myColor Mod 256
        myColor = myColor \ 256
    Next Index
    myRng.Font.Color = -vbWhite * (sum < 384)  '白文字に設定

End Function

'+++*****************************************************+++
'    背景色によって文字色を白か黒に変更: パターン３
'+++*****************************************************+++
Public Function AdjustFontColor3(ByRef myRng As Range)

    Dim R As Long
    Dim G As Long
    Dim B As Long
    Dim Rg As Double
    Dim Gg As Double
    Dim Bg As Double
    Dim L As Double
    Dim RatioBlack As Double
    Dim RatioWhite As Double
    Dim myColor As Long

    Const BASEDBL As Double = 0.03928
    Const BASEDBL2 As Double = 12.92

    myColor = myRng.Interior.Color
    R = (myColor Mod 256) / 255
    G = (Int(myColor / 256) Mod 256) / 255
    B = (Int(myColor / 256 / 256)) / 255

    If R <= BASEDBL Then
        Rg = R / BASEDBL2
    Else
        Rg = ((R + 0.055) / 1.055) ^ 2.4
    End If

    If G <= BASEDBL Then
        Gg = G / BASEDBL2
    Else
        Gg = ((G + 0.055) / 1.055) ^ 2.4
    End If

    If B <= BASEDBL Then
        Bg = B / BASEDBL2
    Else
        Bg = ((B + 0.055) / 1.055) ^ 2.4
    End If

    L = 0.2126 * Rg + 0.7152 * Gg + 0.0722 * Bg
    RatioBlack = (L + 0.05) / 0.05
    RatioWhite = 1.05 / (L + 0.05)
    If RatioBlack > RatioWhite Then
        myRng.Font.Color = vbBlack
    Else
        myRng.Font.Color = vbWhite
    End If

End Function

'+++*****************************************************+++
'    選択範囲の文字色を白or黒 見やすい方に変更
'    変更したい範囲を選択後実行
'+++*****************************************************+++
Public Sub AdjustSelectionFontColor()

    Dim tgtSht As Worksheet
    Dim myRng As Variant
    Dim tetRng As Range
    Dim myC As Range

    Call StopUpdating

    With ActiveSheet
        For Each myC In Selection
            Call AdjustFontColor(myC)
        Next myC
    End With

    Call Updating

End Sub

'+++*****************************************************+++
'    【Actブックテーマ】シートを作成
'+++*****************************************************+++
Public Sub MakeActSht()

    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 strAry5() As Variant
    Dim strAry6() As Variant
    Dim ActSht As Worksheet

    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.6, 3, 5.5, 14, 4, 5)
    cWidth = Array(0, 0.7, 14.6, 18.8, 0.74, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 1.92, 8)
    strAry1 = Array("", "背景1", "テキスト１", "背景２", "テキスト２", _
            "ｱｸｾﾝﾄ1", "ｱｸｾﾝﾄ2", "ｱｸｾﾝﾄ3", "ｱｸｾﾝﾄ4", "ｱｸｾﾝﾄ5", "ｱｸｾﾝﾄ6", _
            "ﾊｲﾊﾟｰﾘﾝｸ", "表示済みのハイパーリンク", "", _
            "テーマ", "", "", "見出しのフォント（英数字）", _
            "本文のフォント (英数字)", "見出しのフォント(日本語)", _
            "本文のフォント(日本語)", "本文のフォント例(英数字)", _
            "本文のフォント例(日本語)")
    strAry2 = Array("", "xlThemeColorDark1", "xlThemeColorLight1", _
            "xlThemeColorDark2", "xlThemeColorLight2", "xlThemeColorAccent1", _
            "xlThemeColorAccent2", "xlThemeColorAccent3", "xlThemeColorAccent4", _
            "xlThemeColorAccent5", "xlThemeColorAccent6", _
            "xlThemeColorFllowedHyperlink", "xlThemeColorHyperlink", "", _
            "テーマ：名前をつけて一覧に保存", "", "", "", "", "", "", _
            "abcdefgh1230OoLl1Ppqrxyz", "あいうえおアイウエオシソンャユヨ")
    strAry3 = Array("", "順序", "ThemeColor", "R", "G", "B", "Color値", "HEX(16進数）", _
            "VBAは ""&H""")
    strAry4 = Array("", "背景１", "テキスト１", "背景２", "テキスト２", "アクセント１", _
            "アクセント２", "アクセント３", "アクセント４", "アクセント５", _
            "アクセント６", "ﾊｲﾊﾟｰﾘﾝｸ", "表示済みのﾊｲﾊﾟｰﾘﾝｸ")
    strAry5 = Array(0, 2, 1, 4, 3, 5, 6, 7, 8, 9, 10, 11, 12)
    strAry6 = Array(0, 192, 255, 49407, 65535, 5296274, 5287936, 15773696, _
            12611584, 6299648, 10498160)
   
    Set ActSht = ThisWorkbook.Worksheets("Actブックテーマ")
    With ActSht
        .Cells.RowHeight = 14#
        For i = 1 To 7
            .Rows(i).RowHeight = rHeight(i)
        Next i
        .Rows(20).RowHeight = rHeight(8)
        .Rows(23).RowHeight = rHeight(8)
        .Rows(30).RowHeight = rHeight(8)
        For i = 1 To 18
            .Columns(i).ColumnWidth = cWidth(i)
        Next i
        .Range("B6:C6").Font.Color = vbWhite
        .Range("B2:Q2").Interior.Color = TTLITRCOLOR
        .Range("B4:Q4").Interior.Color = BARITRCOLOR
        With .Cells.Font
            .Name = "Meiryo UI"
            .Size = 9
        End With
        
        With .Range("B6:Q30")
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlCenter
            .ShrinkToFit = True
        End With
        With Range("B2")
            .Value = "アクティブブックのテーマ取得"
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 2
            With .Cells.Font
                .Size = 16
                .Color = vbWhite
            End With
        End With
        With .Range("E6:L6")
            .Interior.Color = TCOLOR
            .HorizontalAlignment = xlCenter
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("E8:L19")
            .HorizontalAlignment = xlCenter
        End With
        With .Range("E21:P22")
            .HorizontalAlignment = xlCenter
        End With
        With Range("E8:L19").Borders
            .LineStyle = xlContinuous
            .Color = LINECOLOR
            .Weight = xlThin
        End With
        With .Range("C31")
            .Value = "標準色"
            .HorizontalAlignment = xlRight
            .InsertIndent 2
        End With
        For i = 1 To UBound(strAry1)
            .Cells(i + 7, 2) = strAry1(i)
            .Cells(i + 7, 3) = strAry2(i)
        Next i
        For i = 1 To 12
            .Cells(i + 7, 5) = strAry5(i)
        Next i
        For j = 1 To 8
            .Cells(6, j + 4) = strAry3(j)
        Next j
        For j = 1 To 12
            .Cells(21, j + 4) = strAry4(j)
            .Cells(22, j + 4) = strAry5(j)
        Next j
        For j = 1 To 10
            .Cells(31, j + 4) = strAry6(j)
            .Cells(31, j + 4).Interior.Color = strAry6(j)
            Call AdjustFontColor(.Cells(30, j + 4))
        Next j
    End With
    'メモリ線非表示
    ActiveWindow.DisplayGridlines = False

End Sub

'+++*****************************************************+++
'    ■ ConvRGB
'+++*****************************************************+++
Public Function ConvRGB(Num As Long)
    Dim R As Long
    Dim G As Long
    Dim B As Long

    B = Int(Num / 65536)
    G = Int((Num - (B * 65536)) / 256)
    R = Num - (G * 256) - (B * 65536)
    ConvRGB = R & "," & G & "," & B

End Function