私はこのダイアログボックスを気に入っていたりする。

VB4.0時代、このダイアログボックスをどうにかして表示させてやろうといきり立っていた。当時の私のVB知識は、納豆１粒みたいなものであったから当然できなかった。また、ある掲示板によるとVBでは表示不可能という記述があったような気もする…(かなり曖昧だが、それを読み、「やっぱ、駄目なんだなぁ」とあきらめた記憶がある)。

なぜ不可能かというと、CHOOSECOLOR 構造体のメンバ lpCustColors にカスタムカラー配列へのポインタを渡さなければならないが、VBにはそういう機能が無いと思われていたからである。だがある時、それが実現された。API関数 GlobalAlloc、GlobalLock を使用する方法である。また VatPtr 関数を使用する方法も出てきた。VarPtr はオブジェクトブラウザでは隠し関数として位置づけられいる関数で、その機能は、「変数のアドレスを取得する」というもの。Long型の配列変数 CustomColor(15) を宣言し、VarPtr(CustomColor(0)) としてやればよいのである。なるほど、API関数を使うより楽チンではある。が、今後Microsoft がサポートするかは不明なので使わないにこしたことはない(←当時は本当にこのように思っていました(2010/8/6 追記))。その他の方法はないのであろうか。

それではどうするか。VarPtrで渡した変数に注目する。Long型変数が16個、即ち64バイト。ただ、これから単純な発想で String$(64, Chr$(0)) としたら…、驚いたことに動いてしまった。

本当に正しいかどうかは分からないが、ここでのサンプルは String$(64, Chr$(0)) を使用した例にする。

Private Type CHOOSECOLOR
    lStructSize As Long   'この構造体のサイズ
    hWndOwner As Long    '親ウインドウハンドル
    hInstance As Long    'インスタンス
    rgbResult As Long    '選択したRGB値
    lpCustColors As String    'カスタムカラー配列へのポインタ
    flags As Long    '動作指定フラグ
    lCustData As Long   'カスタムダイアログへのデータ
    lpfnHook As Long    'フック関数へのポインタ
    lpTemplateName As String   '???
End Type

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long

Private Const CC_RGBINIT = &H1 'ダイアログボックスの色の初期値を設定する
Private Const CC_LFULLOPEN = &H2 '色の作成を行う部分を表示する
Private Const CC_PREVENTFULLOPEN = &H4 'ダイアログボックスの [色の作成]ボタンを無効にする
Private Const CC_SHOWHELP = &H8   'ヘルプボタンを表示する
Private Const CC_ENABLEHOOK = &H10 'lpfnHoolで指定されたフック関数を有効にする
Private Const CC_ENABLETEMPLATE = &H20 'hInstanceとlpTemplateNameで指定されたダイアログテンプレートを使って作成する
Private Const CC_ENABLETEMPLATEHANDLE = &H40 'hInstanceがロード済みのテンプレートを含むメモリブロックを差す

早速、関数を書いてみます。

'----------------------------------------------------------------
'  関数名 ： GetColorValue
'  機能   ： 色の設定ダイアログボックスを表示し、指定色のRGB値を得る
'  引数   ： (in) hWnd … フォームのハンドル
'  戻り値 ： 成功 ： RGB値
'                キャンセルが押された ：-1
'                エラー ： -2
'----------------------------------------------------------------
Public Function GetColorValue(ByVal hWnd As Long) As Long

    Dim udtChooseColor As CHOOSECOLOR
    Dim ret As Long    'ChooseColor関数の返り値

    With udtChooseColor
        .lStructSize = Len(udtChooseColor)  '構造体のサイズ設定
        .hWndOwner = hWnd            'オーナーハンドルの設定
        .hInstance = App.hInstance    'インスタンス設定
        .lpCustColors = String$(64, Chr$(0))    'カスタムカラー配列の設定
        .flags = CC_RGBINIT              'フラグ設定
    End With

    ret = ChooseColor(udtChooseColor)

    If ret <> 0 Then
        'もし RGB(255, 255, 255) 以上の値を受け取ったらエラー
        If udtChooseColor.rgbResult > RGB(255, 255, 255) Then
            GetColorValue = -2
        Else
            'RGB値をセット
            GetColorValue = udtChooseColor.rgbResult
        End If
    Else
        'キャンセル
        GetColorValue = 0
    End If

  End Function

以下のコードをお試しあれ

Private Sub Command1_Click()
    Me.BackColor = GetColorValue(Me.hWnd)
End Sub