業務アプリケーションの機能として，何かの色を変更するUI（ユーザーインターフェース）を作りたい場合があります。例えば，こちらのアドインでは，路面性状調査の結果の配色を変更できるようにしています。
その一つの方法として，Windows APIを用いる方法を上記のアドインで使用しています。
関数の作成
新しい標準モジュールを作成し，例えばmodGetColorDlgなどと名前を付けておきます。
以下のコードにより，上から順に，Windows APIに関する宣言，構造体の定義，モジュールレベルの定数を宣言したあと，フォームから使用するパブリック関数を作成します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
Option Explicit Private Declare Function ChooseColor Lib "comdlg32.dll" _ Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long Private Type ChooseColor lStructSize As Long hWndOwner As Long hInstance As Long rgbResult As Long lpCustColors As String flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Const CC_RGBINIT = &H1 Private Const CC_LFULLOPEN = &H2 Private Const CC_PREVENTFULLOPEN = &H4 Private Const CC_SHOWHELP = &H8 Public Function GetColorDlg(lngDefColor As Long) As Long Dim udtChooseColor As ChooseColor Dim lngRet As Long With udtChooseColor 'ダイアログの設定 .lStructSize = Len(udtChooseColor) .lpCustColors = String$(64, Chr$(0)) .flags = CC_RGBINIT + CC_LFULLOPEN .rgbResult = lngDefColor lngRet = ChooseColor(udtChooseColor) 'ダイアログを表示 If lngRet <> 0 Then 'ダイアログからの戻り値をチェック If .rgbResult > RGB(255, 255, 255) Then GetColorDlg = -2 'エラーの場合 Else GetColorDlg = .rgbResult '戻り値にRGB値を代入 End If Else GetColorDlg = -1 'キャンセルされた場合 End If End With End Function |
使用例
フォームの準備
色を変更させるUIとして，元の色を表示し，クリックさせ，変更された色を表示する部分として，キャプションに何も記入しないラベルコントロールを設置します。
以下の例ではラベルを凹ませていますが，その他，凸にする，枠を付ける，枠線に色を付けるなど，お好みでスタイルを変更して下さい。
コードの記述
準備したラベルをダブルクリックすると，標準でClickイベントの作成画面になりますので，以下のように記述します。
|
1 2 3 4 5 6 7 8 9 |
Private Sub Label1_Click() Dim Color As Long Color = GetColorDlg(Label1.BackColor) 'キャンセルされなかったらコントロールの色変更 If Color > 0 Then Label1.BackColor = Color End Sub |
実行例
フォームのラベルコントロールをクリックすると，下図のようなダイアログが表示されます。
色を選択して閉じると，ラベルの色も変更されます。
具体的な利用方法としては，色の値は隠しシートあるいはレジストリに保存することが考えられます。
フォームのInitializeイベントで初期値を読み込み，フォームを閉じたときにレジストリやシートに変更された色の値を保存するようにして下さい。