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

質問

コマンドボタンを押すと、カラーパレットを表示し、色を選択したらそのボタン自身の色を選択した色に変更するマクロを作る必要があります。
ですが、自分なりに調べたつもりですが、どうすればよいか判らず、助けて頂きたいのです。

例えば、デザインモードで、コマンドボタンのプロパティ「BackColor」を変更する時に表示されるようなパレットを、マクロで表示し、選択させたタイルの色コードを取得し、そのコマンドボタンの色を変える、というような処理になります。
（イメージは、添付画像をご参照ください。パレットはあくまで例示で、これでないとけない、ということではありません。）

Application.Dialogs(xlDialogColorPalette).Show でダミーセルを着色してから色を拾って、ボタンのBackColorプロパティを変えればできそうな気もしますが、セルとオブジェクトの色数が同じかどうかも確認できていないこともあり、可能なら、もうちょっとスマートなやり方ががあるとよいのですが。

以上について、よろしくお願いします。

回答No.3

mitarashi · ベストアンサー

#1,2です。たびたびすみませんが、カスタムカラーは新規マスを選択後、「色の追加」を押せば良いのでした。
追加したカスタムカラーをワークシートに保存、読み出しする様にしてみました。ご参考まで。
'☆UserFormモジュール
Dim myPalette As Class1

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

Private Sub UserForm_Initialize()
Set myPalette = New Class1
Set myPalette.dataSheet = ThisWorkbook.Sheets(1) '色保存用のワークシートを設定
End Sub

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

'☆Class1モジュール
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_RGBINIT = &H1 'rgbResultで指定したカラー値をデフォルトにする

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 colorAddress As Long
Private colorsize As Long
Private myColorDataSheet As Worksheet

Private Function ColorDialog(ByRef color As Long) As Long
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 rescol As Long

rescol = 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
Else
longret = GlobalFree(memhandle)
End If
End If
End Sub

Private Sub Class_Terminate()
Dim longret As Long
Dim i As Long
Dim strColor As String

'カスタムカラーを配列に書き戻す
Call MoveMemory(custcol(0), ByVal colorAddress, colorsize)
If Not myColorDataSheet Is Nothing Then
With myColorDataSheet
For i = 0 To 15
.Cells(i + 1, 1).Value = Right("000000" & Hex(custcol(i)), 6)
Next i
End With
End If
longret = GlobalUnlock(memhandle)
longret = GlobalFree(memhandle)
End Sub

Public Property Set dataSheet(newSheet As Worksheet)
Dim i As Long

Set myColorDataSheet = newSheet
'最小限のエラー処理、初回用
If myColorDataSheet.Cells(1).Value <> "" Then
With myColorDataSheet
For i = 0 To 15
custcol(i) = CLng("&H" & .Cells(i + 1, 1).Value)
Next i
End With
Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)
End If
End Property

'☆色データ保存用ワークシートの内容例A1以下、A列
0F29E1
34CFE0
26DF79
D5E22C
D92B26
B1387B
C82BC8
CAD2FD
FFFFFF
FFFFFF
1AB321
FFFFFF
FFFFFF
CA3182
FFFFFF
4429C2

お礼

追補の情報ありがとうございます。
やはりこれくらいのコードが必要になるんですね。
惜しげもなくそれを作成・公開して頂けたことに感謝です！

回答No.4

mitarashi

#1～です。しつこくてすみません。ご質問文にあったダミーセルに着色する方法も試してみました。
Application.Dialogs(xlDialogPatterns).Show
の方が良さそうです。ご参考まで。

Private Sub CommandButton1_Click()
Dim workCell As Range
Dim oldColor As Long
Dim noColorFlag As Boolean

Set workCell = ActiveCell
Application.ScreenUpdating = False
If workCell.Interior.Pattern = xlNone Then
noColorFlag = True
Else
oldColor = workCell.Interior.color
End If
'Cellに保護がかかっているとエラーになります。その場合は、
'ActiveCellでなくて、適当な作業セルを指定して下さい。
On Error GoTo errhandle
Application.Dialogs(xlDialogPatterns).Show
' Application.Dialogs(xlDialogColorPalette).Show
Me.CommandButton1.BackColor = workCell.Interior.color
If noColorFlag Then
workCell.Interior.Pattern = xlNone
Else
workCell.Interior.color = oldColor
End If
errhandle:
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Error " & CStr(Err.Number) & vbCrLf & Err.Description
End Sub

お礼

なるほど。Excel VBAらしい手法だと思います。勉強になります。
この度は、本当にありがとうございました。

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

回答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を呼ぶ手法は経験がなく、些か戸惑いが無くはないですが、これは完全なクリアランスです。
クラスモジュールを使うのも、初めての経験ですが、多分これで意味と使い方が理解できます。
そういう意味で、自分にとって勉強の機会でもあり、コードを惜しげもなく公開して下さったことに、いくら言葉を並べても感謝しきれません。

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

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