HOME > エクセルVBA > サンプル > ColorDialog

ColorDialog


【ファイル名】ColorDialog.xlsm
【バージョン】Ver 1.0.1.5
【作成日】2015年05月09日
【更新日】2021年05月31日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ColorDialog.zip
【説明】簡易版の色の設定ダイアログのサンプルです。(Windows APIのChooseColor)

サンプルタブ

色の設定ダイアログのクラスです。

プロパティ
メッソッド

フルサイズの色の設定のダイアログ
フルサイズの色の設定のダイアログ

左側のみ表示の色の設定のダイアログ
左側のみ表示の色の設定のダイアログ

このページの上

customUI.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル">
        <group id="Group1" label="色のダイアログ">
          <button id="ColorButton" label="セル&#13;背景色" supertip="アクティブ セルの背景色をダイアログで選択した色に変更します。" imageMso="ColorPickerCommentFill" size="large" onAction="onAction" />
          <box id="Box1" boxStyle="vertical">
            <checkBox id="RGBINITCheckBox" getPressed="getPressed" label="初期値の色を設定" supertip="ダイアログを表示する前に色を設定する/しないを切り替えます。" onAction="checkBox_Click" />
            <checkBox id="SHOWHELPCheckBox" getPressed="getPressed" label="[ヘルプ]ボタンの表示" supertip="[ヘルプ]ボタンを表示する/しないを切り替えます。" onAction="checkBox_Click" />
          </box>
          <separator id="separator1" />
          <box id="Box2" boxStyle="vertical">
            <checkBox id="FULLOPENCheckBox" getPressed="getPressed" label="フルサイズで表示" supertip="左側だけでなく右側の色の追加なども表示する/しないを切り替えます。&#13;フルサイズで表示すると[色の作成]ボタンは無効になります。" onAction="checkBox_Click" />
            <checkBox id="PREVENTFULLOPENCheckBox" getPressed="getPressed" label="[色の作成]ボタンを無効" supertip="[色の作成]ボタンを無効にする/しないを切り替えます。&#13;最初からフルサイズで表示した場合は無効です。" onAction="checkBox_Click" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

このページの上

RibbonModule
Option Explicit

Private RibbonUI As IRibbonUI ' リボン
Private ColorDialog As New ColorDialogClass ' 色の設定ダイアログ
Private CustomColors(0 To 15) As Long ' カスタム カラー

' リボンの初期処理
Sub onLoad(ribbon As IRibbonUI)
  Dim i As Long
  
  ColorDialog.RGBINIT = True ' ダイアログを表示する前に色を設定します。
  ColorDialog.FULLOPEN = True ' 左側だけでなく右側の色の追加なども表示します。
  ColorDialog.PREVENTFULLOPEN = False '[色の作成]ボタンを無効にしません。
  ColorDialog.SHOWHELP = False '[ヘルプ]ボタンを表示しせん。
  Set RibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットします。
  RibbonUI.Invalidate ' リボンの表示を更新します。
  
  For i = 0 To 15
    If i < ThisWorkbook.Theme.ThemeColorScheme.Count Then ColorDialog.CustomColors(i) = ThisWorkbook.Theme.ThemeColorScheme.Colors(i + 1).RGB
  Next
End Sub

' アクティブ セルの背景色をダイアログで選択した色に変更します。
Sub onAction(control As IRibbonControl)
  If ActiveCell Is Nothing Then Exit Sub
  ColorDialog.Color = ActiveCell.Interior.Color
  If ColorDialog.Show Then ActiveCell.Interior.Color = ColorDialog.Color
End Sub
' チェックボックスにチェックを設定する
Sub getPressed(control As IRibbonControl, ByRef returnedVal)
  Select Case control.ID
    Case "RGBINITCheckBox"
      returnedVal = ColorDialog.RGBINIT
    Case "FULLOPENCheckBox"
      returnedVal = ColorDialog.FULLOPEN
    Case "PREVENTFULLOPENCheckBox"
      returnedVal = ColorDialog.PREVENTFULLOPEN
    Case "SHOWHELPCheckBox"
      returnedVal = ColorDialog.SHOWHELP
  End Select
End Sub
' チェックボックスのクリック処理
Sub checkBox_Click(control As IRibbonControl, pressed As Boolean)
  Select Case control.ID
    Case "RGBINITCheckBox"
      ColorDialog.RGBINIT = pressed
    Case "FULLOPENCheckBox"
      ColorDialog.FULLOPEN = pressed
    Case "PREVENTFULLOPENCheckBox"
      ColorDialog.PREVENTFULLOPEN = pressed
    Case "SHOWHELPCheckBox"
      ColorDialog.SHOWHELP = pressed
  End Select
End Sub

このページの上

ColorDialogClass
Option Explicit
' 色のの設定ダイアログを表示します。(簡易版)
' Colorで色の初期値を指定してShowでダイアログを表示します。戻り値がTrueの場合はColorで色を取得します。

#If Win64 Then ' Office 64ビット
  ' https://msdn.microsoft.com/en-us/library/windows/desktop/ms646830(v=vs.85).aspx
  Private Type TChooseColor
    lStructSize As Long ' このユーザー定義のサイズ
    hwndOwner As LongPtr ' ウィンドウのハンドル
    hInstance As LongPtr ' インスタンスのハンドル
    rgbResult As Long ' 選択した色
    lpCustColors As LongPtr ' カスタム カラー
    flags As Long ' フラグ
    lCustData As LongPtr ' コールバック関数の引数のポインター
    lpfnHook As LongPtr ' コールバック関数のアドレス
    lpTemplateName As LongPtr ' テンプレートのリソースの名前
  End Type
#Else
  Private Type TChooseColor
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
  End Type
#End If
' Flags
Private Const CC_RGBINIT = &H1         ' ダイアログを表示する前に色を設定します。
Private Const CC_FULLOPEN = &H2        ' 左側だけでなく右側の色の追加なども表示します。CC_PREVENTFULLOPENと一緒には使いません。
Private Const CC_PREVENTFULLOPEN = &H4 ' [色の作成]ボタンを無効にします。CC_FULLOPENと一緒には使いません。
Private Const CC_SHOWHELP = &H8        ' [ヘルプ]ボタンを表示します。
' Flagsはもっとありますが、これは簡易版なので使いません。

#If Win64 Then ' Office 64ビット
  ' https://msdn.microsoft.com/en-us/library/windows/desktop/ms646912(v=vs.85).aspx
  Private Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As TChooseColor) As Long
#Else
  Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As TChooseColor) As Long
#End If

Private m_Color As Long ' 色
Private m_RGBINIT As Boolean         ' ダイアログを表示する前に色を設定する/しない
Private m_FULLOPEN As Boolean        ' 左側だけでなく右側の色の追加なども表示する/しない。
Private m_PREVENTFULLOPEN As Boolean '[色の作成]ボタンを無効にする/しない。
Private m_SHOWHELP As Boolean        '[ヘルプ]ボタンを表示する/しない
Private m_CustomColors(0 To 15) As Long ' カスタム カラー

' 初期処理
Private Sub Class_Initialize()
  Dim i As Long
  
  Color = &H0      ' 初期値の色を黒にします。
  RGBINIT = True   ' ダイアログを表示する前に色を設定します。
  FULLOPEN = True  ' 左側だけでなく右側の色の追加なども表示します。
  
  For i = 0 To 15
    m_CustomColors(i) = 0
  Next
End Sub
' 終了処理
Private Sub Class_Terminate()
End Sub
' 色
Public Property Get Color() As Long
  Color = m_Color
End Property
Public Property Let Color(ByVal Value As Long)
  m_Color = Value
End Property
' ダイアログを表示する前に色を設定する/しない
Public Property Get RGBINIT() As Boolean
  RGBINIT = m_RGBINIT
End Property
Public Property Let RGBINIT(ByVal Value As Boolean)
  m_RGBINIT = Value
End Property
' 左側だけでなく右側の色の追加なども表示する/しない
Public Property Get FULLOPEN() As Boolean
  FULLOPEN = m_FULLOPEN
End Property
Public Property Let FULLOPEN(ByVal Value As Boolean)
  m_FULLOPEN = Value
End Property
'[色の作成]ボタンを無効にする/しない
Public Property Get PREVENTFULLOPEN() As Boolean
  PREVENTFULLOPEN = m_PREVENTFULLOPEN
End Property
Public Property Let PREVENTFULLOPEN(ByVal Value As Boolean)
  m_PREVENTFULLOPEN = Value
End Property
'[ヘルプ]ボタンを表示する/しない
Public Property Get SHOWHELP() As Boolean
  SHOWHELP = m_SHOWHELP
End Property
Public Property Let SHOWHELP(ByVal Value As Boolean)
  m_SHOWHELP = Value
End Property
' カスタム カラー
Public Property Get CustomColors(ByVal Index As Long) As Long
  If Index < 0 Or Index > 15 Then
    CustomColors = 0
  Else
    CustomColors = m_CustomColors(Index)
  End If
End Property
Public Property Let CustomColors(ByVal Index As Long, ByVal CustomColor As Long)
  If Index < 0 Or Index > 15 Then Exit Property
  m_CustomColors(Index) = CustomColor
End Property

' 色の設定ダイアログを表示します。戻り値は[OK]ボタンを押すとTrue、[キャンセル]ボタンはFalseになります。
Public Function Show() As Boolean
  Dim Ret As Long
  Dim cc As TChooseColor
  Dim TemplateName As String
  
  With cc
    .lStructSize = LenB(cc)
    .hwndOwner = Application.hWnd
    .flags = 0
    If RGBINIT Then .flags = .flags + CC_RGBINIT
    If FULLOPEN Then .flags = .flags + CC_FULLOPEN
    If PREVENTFULLOPEN Then .flags = .flags + CC_PREVENTFULLOPEN
    If SHOWHELP Then .flags = .flags + CC_SHOWHELP
    .rgbResult = Color
    .lCustData = 0
    .lpfnHook = 0
    TemplateName = String$(1024, vbNullChar) ' 1024は適当なので必要があれば変更してください。
    .lpTemplateName = StrPtr(TemplateName)
    .lpCustColors = VarPtr(m_CustomColors(0))
    Ret = ChooseColor(cc)
    If Ret = 0 Then
      Show = False ' [キャンセル]ボタン
    Else
      If .rgbResult > RGB(255, 255, 255) Then
        Show = False ' 例外
      Else
        Show = True ' OK
        Color = .rgbResult
      End If
    End If
  End With
End Function

このページの上