VBAサンプル集
カラーのコード取得(256RGB⇔16進変換)

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
公開日:2013年5月以前 最終更新日:2020-04-27

カラーのコード取得(256RGB⇔16進変換)


WEB制作等で使用する16進のFFFFFFと、RGB(255,255,255)の変換をワークシートで行います。


10進で指定、16進で指定、スクロールバーで指定、
そして、セルの背景色・文字色を直接指定することができるようにしています。

指定した値が、直ちにセルに反映する為、いろいろと色を選定する時の参考になると思います。

カラーのコード取得のシートレイアウト

以下がワークシートのイメージです。

VBA マクロ  カラーのコード取得

名前定義

参照範囲 名前
C2 サンプル
F11 背景HEX
F10 背景RGB
D8 背景青10
E8 背景青16
D6 背景赤10
E6 背景赤16
D7 背景緑10
E7 背景緑16
M11 文字HEX
M10 文字RGB
K8 文字青10
L8 文字青16
K6 文字赤10
L6 文字赤16
K7 文字緑10
L7 文字緑16

スクロールバー

VBA マクロ  カラーのコード取得

以下がオブジェクト名になります。
scb背景赤
scb背景緑
scb背景青

scb文字赤
scb文字緑
scb文字青

カラーのコード取得のVBAコード

以下は、シートモジュールで作成しています。

Option Explicit

Private Sub サンプル設定()
  With Range("サンプル")
    .Interior.Color = RGB(Range("背景赤10"), Range("背景緑10"), Range("背景青10"))
    .Font.Color = RGB(Range("文字赤10"), Range("文字緑10"), Range("文字青10"))
  End With
  Range("背景RGB") = "(" & Range("背景赤10") & ", " & Range("背景緑10") & ", " & Range("背景青10") & ")"
  Range("背景HEX") = Range("背景赤16") & Range("背景緑16") & Range("背景青16")
  Range("文字RGB") = "(" & Range("文字赤10") & ", " & Range("文字緑10") & ", " & Range("文字青10") & ")"
  Range("文字HEX") = Range("文字赤16") & Range("文字緑16") & Range("文字青16")
End Sub

Private Sub scb背景赤_Change()
  Call ScrollBarChange(scb背景赤)
End Sub
Private Sub scb背景緑_Change()
  Call ScrollBarChange(scb背景緑)
End Sub
Private Sub scb背景青_Change()
  Call ScrollBarChange(scb背景青)
End Sub
Private Sub scb文字赤_Change()
  Call ScrollBarChange(scb文字赤)
End Sub
Private Sub scb文字緑_Change()
  Call ScrollBarChange(scb文字緑)
End Sub
Private Sub scb文字青_Change()
  Call ScrollBarChange(scb文字青)
End Sub

Private Sub ScrollBarChange(ByRef aScrollBar As Variant)
  Application.EnableEvents = False
  Dim sObjName As String
  sObjName = Mid(aScrollBar.Name, 4)
  Range(sObjName & "10") = aScrollBar.Value
  Range(sObjName & "16") = Right("00" & hex(aScrollBar.Value), 2)
  Call サンプル設定
  Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Integer
  Dim strHex1 As Long, strHex2 As Long
  Dim lngColor As Long
  Application.EnableEvents = False
  Select Case Target.Cells(1, 1).Address
    Case Range("サンプル").Address
      Application.ScreenUpdating = False
      lngColor = Range("サンプル").Interior.Color
      scb背景青.Value = Int(lngColor / 256 / 256)
      scb背景緑.Value = Int((lngColor - (scb背景青.Value * 256 * 256)) / 256)
      scb背景赤.Value = lngColor - (scb背景青.Value * 256 * 256) - (scb背景緑.Value * 256)
      lngColor = Range("サンプル").Font.Color
      scb文字青.Value = Int(lngColor / 256 / 256)
      scb文字緑.Value = Int((lngColor - (scb文字青.Value * 256 * 256)) / 256)
      scb文字赤.Value = lngColor - (scb文字青.Value * 256 * 256) - (scb文字緑.Value * 256)
      Application.ScreenUpdating = True
    Case Range("背景赤10").Address
      scb背景赤.Value = Range("背景赤10")
      Call サンプル設定
    Case Range("背景緑10").Address
      scb背景緑.Value = Range("背景緑10")
      Call サンプル設定
    Case Range("背景青10").Address
      scb背景青.Value = Range("背景青10")
      Call サンプル設定
    Case Range("文字赤10").Address
      scb文字赤.Value = Range("文字赤10")
      Call サンプル設定
    Case Range("文字緑10").Address
      scb文字緑.Value = Range("文字緑10")
      Call サンプル設定
    Case Range("文字青10").Address
      scb文字青.Value = Range("文字青10")
      Call サンプル設定
    Case Range("背景赤16").Address
      Call ValueChange(scb背景赤)
    Case Range("背景緑16").Address
      Call ValueChange(scb背景緑)
    Case Range("背景青16").Address
      Call ValueChange(scb背景青)
    Case Range("文字赤16").Address
      Call ValueChange(scb文字赤)
    Case Range("文字緑16").Address
      Call ValueChange(scb文字緑)
    Case Range("文字青16").Address
      Call ValueChange(scb文字青)
  End Select
  Application.EnableEvents = True
End Sub

Private Sub ValueChange(ByRef aScrollBar As Variant)
  Dim sObjName As String
  sObjName = Mid(aScrollBar.Name, 4)
  Range(sObjName & "16") = StrConv(Range(sObjName & "16"), vbUpperCase)
  Dim i As Integer
  i = fnc16to10(Range(sObjName & "16"))
  If i >= 0 Then
    aScrollBar.Value = fnc16to10(Range(sObjName & "16"))
    Call サンプル設定
  Else
    Range(sObjName & "16").Select
  End If
End Sub

Private Function fnc16to10(ByRef rng As Range) As Integer
  If Len(rng.Value) <> 2 Then
    fnc16to10 = -1
    Exit Function
  End If
  On Error Resume Next
  fnc16to10 = CInt("&H" & rng.Value)
  If Err Then
    fnc16to10 = -1
  End If
  On Error GoTo 0
End Function

スクロールバーのオブジェクトの取得が少々回りくどい方法を取っています。
OLEObjects("名称")
このような指定方法では、.Valueが取得できずにエラーとなってしまいます。
OLEObjects("名称").Value
その為、各イベントの中でオブジェクトを直接指定するようにしているため、VBAが回りくどい記述になっています。

カラーのコード取得の解説

VBAコード自体は難しいものではありませんが、
名前定義を始めとしたシートの設定が結構ありますので、
サンプルをダウンロードできるようにしておきました。

サンプルのダウンロード

このままでも使えますが、
むしろ、VBAの勉強も兼ねていろいろと変更して見てください。



同じテーマ「マクロVBAサンプル集」の記事

ユーザー定義関数でフリガナを取得する(GetPhonetic)
ユーザー定義関数でハイパーリンクのURLを取得(Hyperlink)
カラーのコード取得(256RGB⇔16進変換)
時刻になったら音を鳴らして知らせる(OnTime)
指定文字、指定数式でジャンプ機能(Union)
「値の貼り付け」をショートカットに登録(OnKey)
「セルの結合」をショートカットに登録(OnKey)
半角カナのみ全角カナに変換する
計算式の元となる数値定数を消去する(Precedents)
Beep音で音楽(Beep,Sleep)
日付の検索(配列の使用)


新着記事NEW ・・・新着記事一覧を見る

VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
累計を求める数式あれこれ|エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE|エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。|エクセル雑感(2023-12-28)
VBAでクリップボードへ文字列を送信・取得する3つの方法|VBA技術解説(2023-12-07)
難しい数式とは何か?|エクセル雑感(2023-12-07)
スピらない スピル数式 スピらせる|エクセル雑感(2023-12-06)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.変数宣言のDimとデータ型|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.並べ替え(Sort)|VBA入門
8.条件分岐(IF)|VBA入門
9.セルのクリア(Clear,ClearContents)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ