VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SheetPalette"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit

Private Sub Worksheet_Activate()
If SheetCanvas.getBol_Init = False Then 'りっぷ2(りっぷつぅ)が起動していなければ
  MsgBox "左端列にある「Palette」で始まるセルをダブルクリックすると、" & Chr(10) _
  & "その下の表の通りにブックのカラーパレットが設定されます" & Chr(10) _
  & Chr(10) & "左端列のセルが「Palette##」のセルをダブルクリックすると、" & Chr(10) _
  & "その下の表にブックのカラーパレット情報を出力します" & Chr(10)
End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Ipt_name As String
Dim Msg_ans As Long, Row_no As Long, For_r As Long, For_c As Long, For_cnt As Long, Clr_ind As Long
Dim Clr_rgb(2) As Long
If Target = "Palette##" Then
  Row_no = Target.Row + 1
  Msg_ans = MsgBox("ブックのカラーパレットをここに書き出します", vbYesNo)
  If Msg_ans = 6 Then 'はい
    Cancel = True '右ックリックイベントをキャンセル
    Application.ScreenUpdating = False '画面更新オフ
    Ipt_name = InputBox("Palette##の「##」に代わる名前をつけてください")
    Target = "Palette" & Ipt_name
    With ActiveWorkbook
      For For_r = 1 To 7
        For For_c = 1 To 29 Step 4
          Clr_ind = CLng(Val(Cells(Row_no + For_r, For_c)))
          If 0 < Clr_ind And Clr_ind < 57 Then '56色パレット
            Ipt_name = Right$("00000" & Hex(.Colors(Clr_ind)), 6) '16進数に変換
            Cells(Row_no + For_r, For_c + 3) = Right$(Ipt_name, 2) 'R
            Cells(Row_no + For_r, For_c + 2) = Mid$(Ipt_name, 3, 2) 'G
            Cells(Row_no + For_r, For_c + 1) = Left$(Ipt_name, 2) 'B
          End If
        Next For_c
      Next For_r
    End With
    Application.ScreenUpdating = True '画面更新オン
  Else
    Exit Sub '帰る
  End If
End If
If Target Like "Palette*" Then
  Row_no = Target.Row + 1
Else
  Exit Sub
End If
Msg_ans = MsgBox(Target & "をこのブックのカラーパレットに設定しますか", vbYesNo)
If Msg_ans = 6 Then 'はい
  Cancel = True '右ックリックイベントをキャンセル
  Application.ScreenUpdating = False '画面更新オフ
  Cells.Font.ColorIndex = xlAutomatic 'フォントの色、自動
  Cells.Interior.ColorIndex = -4142 '塗りつぶしの色、なし
  With ActiveWorkbook
    For For_r = 1 To 7
      For For_c = 1 To 29 Step 4
        Clr_ind = CLng(Val(Cells(Row_no + For_r, For_c)))
        If 0 < Clr_ind And Clr_ind < 57 Then '56色パレット
          Clr_rgb(0) = CLng(Val("&H" & Cells(Row_no + For_r, For_c + 3)))
          Clr_rgb(1) = CLng(Val("&H" & Cells(Row_no + For_r, For_c + 2)))
          Clr_rgb(2) = CLng(Val("&H" & Cells(Row_no + For_r, For_c + 1)))
          For For_cnt = 0 To 2 'R、G、Bを繰り返し
            If Clr_rgb(For_cnt) < 0 Then '範囲、0〜255
              Clr_rgb(For_cnt) = 0
            ElseIf Clr_rgb(For_cnt) > 255 Then
              Clr_rgb(For_cnt) = 255
            End If
          Next For_cnt
          .Colors(Clr_ind) = RGB(Clr_rgb(0), Clr_rgb(1), Clr_rgb(2)) 'カラーパレット変更
          Cells(Row_no + For_r, For_c).Resize(1, 4).Interior.ColorIndex = Clr_ind 'セルを塗りつぶし
        End If
      Next For_c
    Next For_r
  End With
  For For_r = 1 To 7
    For For_c = 1 To 29 Step 4
      If CLng(Val("&H" & Cells(Row_no + For_r, For_c + 3))) _
        + CLng(Val("&H" & Cells(Row_no + For_r, For_c + 2))) _
        + CLng(Val("&H" & Cells(Row_no + For_r, For_c + 1))) > 380 Then '色が薄ければ
        Cells(Row_no + For_r, For_c).Resize(1, 4).Font.Color = &H0 '文字色を、黒に近い色にする
      Else
        Cells(Row_no + For_r, For_c).Resize(1, 4).Font.Color = &HFFFFFF '文字色を、白に近い色にする
      End If
    Next For_c
  Next For_r
  Application.ScreenUpdating = True '画面更新オン
End If
End Sub