コマンドボタンの色をパレットを表示して選ばせたい

質問

• コマンドボタンを押すと、カラーパレットを表示し、色を選択したらそのボタン自身の色を選択した色に変更するマクロを作る必要があります。
• デザインモードで、コマンドボタンのプロパティ「BackColor」を変更する時に表示されるようなパレットを、マクロで表示し、選択させたタイルの色コードを取得し、そのコマンドボタンの色を変える、という処理になります。
• 可能なら、もうちょっとスマートなやり方があるとよいのですが。

回答No.1

mitarashi

古いコレクションから引っ張り出しましたが動作しました。Window7Home-64bit + xl2010-32bit
時代も変わっているので、もっと簡単な方法もあるかも。ご参考まで。
☆UserForm1モジュール
Dim myPalette As Class1

Private Sub UserForm_Initialize()
Set myPalette = New Class1
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Set myPalette = Nothing
End Sub

Private Sub CommandButton1_Click()
Me.CommandButton1.BackColor = myPalette.colorCode
End Sub

☆Class1モジュール - 挿入、クラスモジュールで生成されるClass1モジュールに記述して下さい。

'色選択のダイアログを表示して、色コードを取得するクラス
'プロパティ　colorCode　に色のコードを与える

Private Type YCHOOSECOLOR
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 String
End Type

Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_RGBINIT = &H1
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Declare Function Color_Choose Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As YCHOOSECOLOR) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)

Private myColorCode As Long

'==============================================
'色指定のダイアログボックスを呼び出す関数
Private Function ColorDialog(ByRef color As Long) As Long
'戻り値は、1の場合は色の選択、0の場合はキャンセルボタンのクリックになります。
'引数colorに選択された色コードをセットします。
Dim col As YCHOOSECOLOR
Dim longret As Long
Dim longret2 As Long
Dim custcol(15) As Long
Dim rescol As Long
Dim I As Integer
Dim colorsize As Long
Dim colorAddress As Long
Dim memhandle As Long

rescol = 0
longret2 = 0
For I = 0 To 15
custcol(I) = &HFFFFFF
Next
colorsize = Len(custcol(0)) * 16
memhandle = GlobalAlloc(GHND, colorsize)
If memhandle Then
colorAddress = GlobalLock(memhandle)
If colorAddress Then
Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)
With col
.lStructSize = Len(col)
.hInstance = 0&
.rgbResult = rescol
.lpCustColors = colorAddress
.flags = CC_RGBINIT
.lCustData = 0&
.lpfnHook = 0&
.lpTemplateName = 0&
End With
longret2 = Color_Choose(col)
longret = GlobalUnlock(memhandle)
longret = GlobalFree(memhandle)
Else
longret = GlobalFree(memhandle)
End If
End If
color = col.rgbResult
'Color_Choose関数の戻り値をを戻す 0:キャンセル、1:色が選択された
ColorDialog = longret2
End Function

Public Property Get colorCode() As Long
Dim ret As Long

ret = ColorDialog(myColorCode)
colorCode = myColorCode
End Property

お礼

この短時間に、これほど高度なご回答を頂けるとは夢にも思っていませんでした。
素晴らしいスキルをお持ちの方だとお見受け致します。
実は、VBA初心者からやっと頭一つ抜け出した程度なので、ガッカリなさらないで頂きたいのですが。
DLLを呼ぶ手法は経験がなく、些か戸惑いが無くはないですが、これは完全なクリアランスです。
クラスモジュールを使うのも、初めての経験ですが、多分これで意味と使い方が理解できます。
そういう意味で、自分にとって勉強の機会でもあり、コードを惜しげもなく公開して下さったことに、いくら言葉を並べても感謝しきれません。

恐縮ですが、私のスキル不足のせいで動作しない可能性も鑑み、少しの間、ここを閉じずに置き、補足を入れさせて頂くかもしれません。
その節は、お手間でなければ、ご指導を仰がせて頂けたら幸いです。

この度は、本当にありがとうございました。