|
'---------------------------------------------------------------
' セル・フォントの色コード一覧表の作成マクロ
' 図形の線・塗りつぶしの色コード一覧表の作成マクロ
' このまま、コピペして使用できます。
' 1. カラーインデックスコードと色( 色コード一覧表 )
' 2. セルの色削除
' 3. RGBコードでセルの色付け
' 1項で作成した表を一度セルの色だけ削除した表のRGBコードを
' 使用してセルに色けします。
' 4. 全ての図線を削除
' 5. 直線_カラーインデックスコードで色付け( 色コード一覧表 )
' 6. 直線_RGBコードで色付け
' 5項で作成した表を一度線だけ削除した表のRGBコードを
' 使用して色付きの直線を描きます。
'---------------------------------------------------------------
Sub カラーインデックスコードと色()
Dim i, r, x As Single
Dim HEX_code, R_code, G_code, B_code As String
x = -5
r = 1
For i = 1 To 56
If r = 1 Or r = 22 Then
x = x + 5: r = 1
Cells(r, x + 1) = "ColorIndex No"
yy = r: xx = x + 1: 折返し中央表示 xx, yy
Cells(r, x + 2) = "Indexコードで塗潰し"
yy = r: xx = x + 2: 折返し中央表示 xx, yy
Cells(r, x + 3) = "10進コード"
yy = r: xx = x + 3: 折返し中央表示 xx, yy
Cells(r, x + 4) = "RGB コード"
yy = r: xx = x + 4: 折返し中央表示 xx, yy
r = 2
End If
'
Cells(r, x + 1) = i
yy = r: xx = x + 1: 中央表示 xx, yy
Cells(r, x + 2).Interior.ColorIndex = i
Cells(r, x + 3) = Cells(r, x + 2).Interior.Color ' 背景色取得
'
' 10進コードを一度16進コードに変換し、R,G,B 毎 10進コードに変換する。
'
HEX_code = Right("000000" & Hex(Cells(r, x + 2).Interior.Color), 6)
'
R_code = Right(" " & CStr(CDec("&H" & Right(HEX_code, 2))), 3)
G_code = Right(" " & CStr(CDec("&H" & Mid(HEX_code, 3, 2))), 3)
B_code = Right(" " & CStr(CDec("&H" & Left(HEX_code, 2))), 3)
'
Cells(r, x + 4).Select
Selection.NumberFormatLocal = "@" ' セルの書式を文字列にする
' コードによっては、３桁毎の , になり数値になるので強制的に
' 文字列にする。
Cells(r, x + 4) = R_code & "," & G_code & "," & B_code
yy = r: xx = x + 4: 中央表示 xx, yy
'
Cells(r, x + 1).Select
With Selection.Font
.Name = "Century Gothic" ' 文字をCentury Gothicにする
.Bold = True ' 太字にする
End With
'
r = r + 1
Next
セルサイズ編集
' 枠線引く
Range("A1:N21").Borders.LineStyle = True
'
End Sub
'---------------------------------------------------------------
Sub 折返し中央表示(xx, yy As Variant)
Cells(yy, xx).Select
With Selection
.HorizontalAlignment = xlCenter ' 中央表示
.WrapText = True ' 折返し表示
End With
End Sub
'---------------------------------------------------------------
Sub 中央表示(xx, yy As Variant)
Cells(yy, xx).Select
With Selection
.HorizontalAlignment = xlCenter ' 中央表示
End With
End Sub
'---------------------------------------------------------------
Sub セルサイズ編集()
'
Rows("1:1").RowHeight = 27.75
Columns("A:A").ColumnWidth = 9.25
Columns("F:F").ColumnWidth = 9.25
Columns("K:K").ColumnWidth = 9.25
Columns("E:E").ColumnWidth = 1
Columns("J:J").ColumnWidth = 1
Columns("B:B").ColumnWidth = 9.75
Columns("G:G").ColumnWidth = 9.75
Columns("L:L").ColumnWidth = 9.75
Columns("C:C").ColumnWidth = 8.75
Columns("H:H").ColumnWidth = 8.75
Columns("M:M").ColumnWidth = 8.75
Columns("D:D").ColumnWidth = 11
Columns("I:I").ColumnWidth = 11
Columns("N:N").ColumnWidth = 11
End Sub
'---------------------------------------------------------------
Sub セルの色削除()
Range("A1:N21").Select
Selection.Interior.Pattern = xlNone
Range("A1").Select
End Sub
'---------------------------------------------------------------
Sub RGBコードでセルの色付け()
'
' RGB色コードの検証
'
Dim i, r, x As Single
Dim R_code, G_code, B_code As Long
x = -5
r = 1
For i = 1 To 56
If r = 1 Or r = 22 Then
x = x + 5: r = 2
End If
' RGB コードの文字列から、赤・緑・青の文字列データを抜出し、
' 数値に変換する
R_code = Val(Mid(Cells(r, x + 4).Value, 1, 3)) ' 赤
G_code = Val(Mid(Cells(r, x + 4).Value, 5, 3)) ' 緑
B_code = Val(Right(Cells(r, x + 4).Value, 3)) ' 青
Cells(r, x + 2).Interior.Color = _
RGB(R_code, G_code, B_code) ' セルの色付け
'
r = r + 1
Next
End Sub
'
'---------------------------------------------------------------
' ここからは、図形の色コード
'---------------------------------------------------------------
'
Sub 全ての図線を削除()
' 全ての図・線を削除する。
ActiveSheet.Shapes.SelectAll
Selection.Delete
End Sub
'---------------------------------------------------------------
Sub 直線_カラーインデックスコードで色付け()
Dim i, r, x As Single
Dim HEX_code, Line_name As String
Dim x1, x2, y1, y2 As Long
x = -5
r = 1
For i = 1 To 56
If r = 1 Or r = 22 Then
x = x + 5: r = 1
Cells(r, x + 1) = "ColorIndex No"
yy = r: xx = x + 1: 折返し中央表示 xx, yy
Cells(r, x + 2) = "Indexコードで色付け"
yy = r: xx = x + 2: 折返し中央表示 xx, yy
Cells(r, x + 3) = "10進コード"
yy = r: xx = x + 3: 折返し中央表示 xx, yy
Cells(r, x + 4) = "RGBコード"
yy = r: xx = x + 4: 折返し中央表示 xx, yy
r = 2
End If
'
Cells(r, x + 1) = i
yy = r: xx = x + 1: 中央表示 xx, yy
Cells(r, x + 2).Select
' -------- 直線線引き ------------
'
With Selection ' 選択したセルの座標位置・サイズを取得する
x1 = .Left ' 横位置
y1 = .Top ' 縦位置
x2 = .Width ' セルの幅
y2 = .Height ' セルの高さ
End With
' 選択したセルの中央に線を引く +2, -2 は、線が罫線に
' かからない様にする為
ActiveSheet.Shapes.AddLine(x1 + 2, y1 + y2 / 2, x1 + x2 - 2, _
y1 + y2 / 2).Select
Selection.ShapeRange.Line.Weight = 3 ' 線の太さ
Selection.ShapeRange.Line.ForeColor.SchemeColor = _
i ' 線の色 ColorIndex 番号
Selection.ShapeRange.Line.BeginArrowheadStyle = _
msoArrowheadNone ' 線の端 矢印なし
Selection.ShapeRange.Line.EndArrowheadStyle = _
msoArrowheadNone ' 線の端 矢印なし
Line_name = Selection.Name ' 線の描画名を取得する
' ---------------------------------
Cells(r, x + 3) = _
ActiveSheet.Shapes(Line_name).Line.ForeColor ' 線の色取得
'
' 10進コードを一度16進コードに変換し、R,G,B 毎 10進コードに変換する。
'
HEX_code = Right("000000" & Hex(Cells(r, x + 3).Value), 6)
'
R_code = Right(" " & CStr(CDec("&H" & Right(HEX_code, 2))), 3)
G_code = Right(" " & CStr(CDec("&H" & Mid(HEX_code, 3, 2))), 3)
B_code = Right(" " & CStr(CDec("&H" & Left(HEX_code, 2))), 3)
'
Cells(r, x + 4).Select
Selection.NumberFormatLocal = "@" ' セルの書式を文字列にする
' コードによっては、３桁毎の , になり数値になるので強制的に
' 文字列にする。
Cells(r, x + 4) = R_code & "," & G_code & "," & B_code
yy = r: xx = x + 4: 中央表示 xx, yy
'
Cells(r, x + 1).Select
With Selection.Font
.Name = "Century Gothic" ' 文字をCentury Gothicにする
.Bold = True ' 太字にする
End With
'
r = r + 1
Next
セルサイズ編集
' 枠線引く
Range("A1:N21").Borders.LineStyle = True
End Sub
'---------------------------------------------------------------
Sub 直線_RGBコードで色付け()
'---------------------------------------------------------------
' RGBコードの検証
'---------------------------------------------------------------
Dim i, r, x As Single
Dim RGB_color As Variant
Dim Line_name As String
Dim x1, x2, y1, y2, R_code, G_code, B_code As Long
x = -5
r = 1
For i = 1 To 56
If r = 1 Or r = 22 Then
x = x + 5: r = 2
End If
'
Cells(r, x + 2).Select
' -------- 直線線引き ------------
'
With Selection ' 選択したセルの座標位置・サイズを取得する
x1 = .Left ' 横位置
y1 = .Top ' 縦位置
x2 = .Width ' セルの幅
y2 = .Height ' セルの高さ
End With
' 選択したセルの中央に線を引く
ActiveSheet.Shapes.AddLine(x1, y1 + y2 / 2, x1 + x2, _
y1 + y2 / 2).Select
'
Selection.ShapeRange.Line.Weight = 2 ' 線の太さ
' RGB コードの文字列から、赤・緑・青の文字列データを
' 抜出し、数値に変換する
R_code = Val(Mid(Cells(r, x + 4).Value, 1, 3)) ' 赤
G_code = Val(Mid(Cells(r, x + 4).Value, 5, 3)) ' 緑
B_code = Val(Right(Cells(r, x + 4).Value, 3)) ' 青
' RGBコードで線に色付け
Selection.ShapeRange.Line.ForeColor.RGB = _
RGB(R_code, G_code, B_code) ' 線の色
Selection.ShapeRange.Line.BeginArrowheadStyle = _
msoArrowheadNone ' 線の端 矢印なし
Selection.ShapeRange.Line.EndArrowheadStyle = _
msoArrowheadNone ' 線の端 矢印なし
' ---------------------------------
'
r = r + 1
Next
セルサイズ編集
End Sub
|
|