在VBA中调用调色板的几种方法

楼主
chrisfang

在有些程序中，需要向用户提供选择颜色的功能，调用Excel或Windows的调色板是一种比较理想的交互方式，关于在VBA中如何调用调色板，本人总结了以下几种方法：

（以下程序以用户窗体中调用调色板修改Label1的标签字体颜色ForeColor为例）

方法一：调用单元格格式中的“字体”选项卡对话框。

Private Sub CommandButton1_Click()
'保存活动单元格当前字体格式设置
With ActiveCell.Font
x_name = .Name
x_fontstyle = .FontStyle
x_size = .Size
x_Strikethrough = .Strikethrough
x_Superscript = .Superscript
x_Subscript = .Subscript
x_OutlineFont = .OutlineFont
x_Shadow = .Shadow
x_Underline = .Underline
x_ColorIndex = .ColorIndex
End With
dlg = Application.Dialogs(xlDialogActiveCellFont).Show '调用活动单元格字体设置选项卡对话框
'************其他类似对话框*************
'Application.Dialogs(xlDialogFontProperties).Show
'Application.Dialogs(xlDialogFormatFont).Show
'Application.Dialogs(xlDialogFont).Show
'Application.Dialogs(xlDialogPatterns).Show '单元格底纹设置
'Application.Dialogs(xlDialogReplaceFont).Show '查找替换对话框中的字体设置
'Application.Dialogs(xlDialogStandardFont).Show
'************************************
If dlg = True Then
Application.ScreenUpdating = False
Me.Label1.ForeColor = ActiveCell.Font.Color
'恢复活动单元格原有字体格式设置
With ActiveCell.Font
.Name = x_name
.FontStyle = x_fontstyle
.Size = x_size
.Strikethrough = x_Strikethrough
.Superscript = x_Superscript
.Subscript = x_Subscript
.OutlineFont = x_OutlineFont
.Shadow = x_Shadow
.Underline = x_Underline
.ColorIndex = x_ColorIndex
End With
Application.ScreenUpdating = True
End If
End Sub

这个方法的缺点是显示的对话框中不仅仅包含颜色设置，还有字体、加粗、斜体等等其他字体格式，虽然在代码中屏蔽了颜色以外的设置功能，但还是容易引起用户误解。当然，如果需要设置字体的更多格式，还是比较适合使用此方法。

方法二：调用Excel中的“编辑颜色对话框”
在Excel的选项设置中，有一项Excel调色板的设置（Excel2003菜单：工具—选项—颜色—修改），可以对Excel调色板中的56种颜色进行编辑修改自定义，此方法就是调用这里的编辑颜色对话框。

Private Sub CommandButton2_Click()
oldcolor = ActiveWorkbook.Colors(1) '保存活动工作簿中调色板第一格的当前颜色
If Application.Dialogs(xlDialogEditColor).Show(1) = True Then '调用编辑颜色对话框，选择的颜色将返回到调色板的第一格
'************其上一级对话框，但不太适合使用*************
'Application.Dialogs(xlDialogColorPalette).Show
'Application.Dialogs.Item(xlDialogColorPalette).Show
'*************************************************
Me.Label1.ForeColor = ActiveWorkbook.Colors(1)
ActiveWorkbook.Colors(1) = oldcolor '恢复活动工作簿调色板第一格的原有颜色
End If
End Sub

这个方法是个人比较推荐的一种方法，操作简单。网上有不少地方都提到使用Application.Dialogs(xlDialogColorPalette).Show这个对话框，但从实际使用上来看，还是现在这个对话框（xlDialogEditColor）更合适。

方法三：调用WindowsAPI，调用Windows的调色板

Private Type CHOOSECOLOR
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 Long
End Type
Private Type RGBColor
R As Byte
G As Byte
B As Byte
space As Byte '用作间隔
End Type
Private Declare Function ChooseColorA Lib "Comdlg32" (pChoosecolor As CHOOSECOLOR) As Long
Dim CustColors(1 To 16) As RGBColor
Private Sub CommandButton3_Click()
Dim CColor As CHOOSECOLOR
With CColor
.lStructSize = Len(CColor) '结构长度
.lpCustColors = VarPtr(CustColors(1)) '存储自定义颜色的缓冲区地址，CustColors为公共变量，用于保存自定义颜色，以便于用户下一次打开调色板时仍能够使用前一次的自定义颜色
End With
If ChooseColorA(CColor) = 0 Then Exit Sub '等于0表示按下了取消键
Me.Label1.ForeColor = CColor.rgbResult
End Sub

此方法为API调用，调用的是Windows系统的调色板，稍显繁琐。
其中CColor.lpCustColors指向16种自定义颜色的地址，如果要在程序运行过程中保存用户的自定义颜色，使得任何时候打开调色板都可以继续使用之前所定义的颜色，可以通过定义CustColors(1 to 16) As Byte为公共变量，然后使用VarPtr函数转换后将VarPtr(CustColors(1))赋值给CColor.lpCustColors。上面的代码中定义了类型RGBColor，主要用于方便程序处理中取得自定义颜色的RGB值，实际使用中并非必需。
如果不需要保存自定义颜色，lpCustColors的赋值比较随意。

方法四：使用CommonDialog控件，调用Windows调色板，需要系统控件支持。（Windows7中好像没有这个控件）

Private Sub CommandButton4_Click()
On Error GoTo zz
Me.CommonDialog1.CancelError = True
Me.CommonDialog1.ShowColor
Me.Label1.ForeColor = CommonDialog1.Color
Exit Sub
zz:
End Sub

此方法也是调用Windows中的调色板，其缺点就是需要附带控件，Xp中一般都包含了CommonDialog控件。

包含以上代码的综合附件：

调色板.rar

综合以上几种方法来看，个人比较推荐方法二，简单易行，而且使用的是Excel中的调色板，还可以自定义颜色。如果对API比较熟悉，也可以使用方法三。除此以外，也可以自己制作一个调色板窗体供用户选择颜色。例如下面这个John-Walkenbach的作品：

2楼
wangqilong1980

Private Sub CommandButton1_Click()
'保存活动单元格当前字体格式设置
With ActiveCell.Font
   x_name = .Name
   x_fontstyle = .FontStyle
   x_size = .Size
   x_Strikethrough = .Strikethrough
   x_Superscript = .Superscript
   x_Subscript = .Subscript
   x_OutlineFont = .OutlineFont
   x_Shadow = .Shadow
   x_Underline = .Underline
   x_ColorIndex = .ColorIndex
End With
dlg = Application.Dialogs(xlDialogActiveCellFont).Show '调用活动单元格字体设置选项卡对话框

'************其他类似对话框*************
'Application.Dialogs(xlDialogFontProperties).Show
'Application.Dialogs(xlDialogFormatFont).Show
'Application.Dialogs(xlDialogFont).Show
'Application.Dialogs(xlDialogPatterns).Show '单元格底纹设置
'Application.Dialogs(xlDialogReplaceFont).Show  '查找替换对话框中的字体设置
'Application.Dialogs(xlDialogStandardFont).Show
'************************************
If dlg = True Then
Application.ScreenUpdating = False
Me.Label1.ForeColor = ActiveCell.Font.Color

'恢复活动单元格原有字体格式设置
With ActiveCell.Font
   .Name = x_name
   .FontStyle = x_fontstyle
   .Size = x_size
   .Strikethrough = x_Strikethrough
   .Superscript = x_Superscript
   .Subscript = x_Subscript
   .OutlineFont = x_OutlineFont
   .Shadow = x_Shadow
   .Underline = x_Underline
   .ColorIndex = x_ColorIndex
End With

Application.ScreenUpdating = True
End If
End Sub

3楼
JOYARK1958

感谢分享!下载学习.