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

質問

• コマンドボタンを押すと、カラーパレットを表示し、色を選択したらそのボタン自身の色を選択した色に変更するマクロを作る必要があります。
• デザインモードで、コマンドボタンのプロパティ「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

お礼

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