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

質問

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

回答No.2

mitarashi

#1です。お褒めにあずかり光栄ですが、#1のコードはクラスを使っている意味が無いですね。VBA ChooseColorAで検索すると、もっと簡単なコードがみつかります。クラスを使うからにはカスタムカラーの保存(UserFormが存在する間）が出来なければ変という事でやってみましたが、「色の追加」をすると、最初のカスタムカラーが都度上書きされてしまいます。仕方が無いので他のカスタムカラーが使いたければ、コードの中でご指定下さい。
クラスモジュールのみの改訂版です。
Private Declare Function Color_Choose Lib "comdlg32.dll" Alias "ChooseColorA" _
(pChoosecolor As YCHOOSECOLOR) As Long
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_ANYCOLOR = &H100
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_FULLOPEN = &H2
Private Const CC_PREVENTFULOPEN = &H4
Private Const CC_RGBINIT = &H1
Private Const CC_SHOWHELP = &H8
Private Const CC_SOLDCOLOR = &H80

Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

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 col As YCHOOSECOLOR
Private custcol(15) As Long
Private memhandle As Long

Private Function ColorDialog(ByRef color As Long) As Long
'戻り値は、1は色の選択、0はキャンセル
'引数colorに選択された色コードをセットします。
Dim longret2 As Long

longret2 = 0
longret2 = Color_Choose(col)
color = col.rgbResult
ColorDialog = longret2
End Function

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

ret = ColorDialog(myColorCode)
colorCode = myColorCode
End Property

Private Sub Class_Initialize()
Dim longret As Long
Dim I As Integer
Dim colorsize As Long
Dim colorAddress As Long
Dim rescol As Long

rescol = 0
For I = 0 To 15
custcol(I) = &HFFFFFF
Next
'カスタムカラーを設定してみる、custcol(0)は色の作成で置換される
custcol(1) = RGB(&HCC, &HCC, &HFF)
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
Else
longret = GlobalFree(memhandle)
End If
End If
End Sub

Private Sub Class_Terminate()
Dim longret As Long

longret = GlobalUnlock(memhandle)
longret = GlobalFree(memhandle)
End Sub

お礼

何を言っても遅いのですが。
OkWave慣れしていなかったのもあって、お礼をするのを失念しているうちにシステムに質問を締め切られてしまって、もう、何もお伝えできないものとばかり思っていましたが、お礼はできたんですね。
素晴らしいご回答者に数々の非礼を働いたことは誠に申し訳なく遺憾に思いますが、頂戴したコードは大いに有効に活用させて頂いております。
心より感謝申し上げます。ありがとうございました。