It's strange that this doesn't have more of a presence on these forums than it does, but hey ho.
Attached is the my ChooseColorAPI wrapper that I've just polished up. Here are its features:
Beyond that, it's pretty much the standard ChooseColorAPI function.
More could be done with this thing, but this is precisely what I needed, and I thought I'd share.
Here's code for a standard BAS module (everything needed, just focus on the ShowColorDialog procedure):
And, if you wish to just test/play, here's a bit of code for a Form1:
Enjoy,
Elroy
Attached is the my ChooseColorAPI wrapper that I've just polished up. Here are its features:
- It just always opens allowing you to select custom colors.
- You can save the user-specified custom colors if you so choose (your application specific).
- It has the ability of allowing you to specify your own dialog title.
- You can double-click on the colors and they will auto-select and be returned to you.
Beyond that, it's pretty much the standard ChooseColorAPI function.
More could be done with this thing, but this is precisely what I needed, and I thought I'd share.
Here's code for a standard BAS module (everything needed, just focus on the ShowColorDialog procedure):
Code:
Option Explicit
'
' These are used to get information about how the dialog went.
Public ColorDialogSuccessful As Boolean
Public ColorDialogColor As Long
'
Private Type ChooseColorType
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 Enum ChooseColorFlagsEnum
CC_RGBINIT = &H1 ' Make the color specified by rgbResult be the initially selected color.
CC_FULLOPEN = &H2 ' Automatically display the Define Custom Colors half of the dialog box.
CC_PREVENTFULLOPEN = &H4 ' Disable the button that displays the Define Custom Colors half of the dialog box.
CC_SHOWHELP = &H8 ' Display the Help button.
CC_ENABLEHOOK = &H10 ' Use the hook function specified by lpfnHook to process the Choose Color box's messages.
CC_ENABLETEMPLATE = &H20 ' Use the dialog box template identified by hInstance and lpTemplateName.
CC_ENABLETEMPLATEHANDLE = &H40 ' Use the preloaded dialog box template identified by hInstance, ignoring lpTemplateName.
CC_SOLIDCOLOR = &H80 ' Only allow the user to select solid colors. If the user attempts to select a non-solid color, convert it to the closest solid color.
CC_ANYCOLOR = &H100 ' Allow the user to select any color.
End Enum
#If False Then ' Intellisense fix.
Public CC_RGBINIT, CC_FULLOPEN, CC_PREVENTFULLOPEN, CC_SHOWHELP, CC_ENABLEHOOK, CC_ENABLETEMPLATE, CC_ENABLETEMPLATEHANDLE, CC_SOLIDCOLOR, CC_ANYCOLOR
#End If
Private Type KeyboardInput '
dwType As Long ' Set to INPUT_KEYBOARD.
wVK As Integer ' shift, ctrl, menukey, or the key itself.
wScan As Integer ' Not being used.
dwFlags As Long ' HARDWAREINPUT hi;
dwTime As Long ' Not being used.
dwExtraInfo As Long ' Not being used.
dwPadding As Currency ' Not being used.
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const WM_LBUTTONDBLCLK As Long = 515&
Private Const WM_SHOWWINDOW As Long = 24&
Private Const WM_SETTEXT As Long = &HC&
Private Const INPUT_KEYBOARD As Long = 1&
Private Const KEYEVENTF_KEYUP As Long = 2&
Private Const KEYEVENTF_KEYDOWN As Long = 0&
'
Private muEvents(1) As KeyboardInput ' Just used to emulate "Enter" key.
Private pt32 As POINTAPI
Private msColorTitle As String
'
Private Declare Function ChooseColorAPI Lib "comdlg32" Alias "ChooseColorA" (pChoosecolor As ChooseColorType) As Long
Private Declare Function SendInput Lib "user32" (ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Private Declare Function SetFocusTo Lib "user32" Alias "SetFocus" (Optional ByVal hWnd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ChildWindowFromPointEx Lib "user32" (ByVal hWnd As Long, ByVal xPoint As Long, ByVal yPoint As Long, ByVal uFlags As Long) As Long
Private Declare Function SendMessageWLong Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'
Public Function ShowColorDialog(hWndOwner As Long, Optional NewColor As Long, Optional Title As String = "Select Color", Optional CustomColorsHex As String) As Boolean
' You can optionally use ColorDialogSuccessful & ColorDialogColor or the return of ShowColorDialog and NewColor. They will be the same.
'
' CustomColorHex is a comma separated hex string of 16 custom colors. It's best to just let the user specify these, starting out with all black.
' If this CustomColorHex string doesn't separate into precisely 16 values, it's ignored, resulting with all black custom colors.
' The string is returned, and it's up to you to save it if you wish to save your user-specified custom colors.
' These will be specific to this program, because this is your CustomColorsHex string.
'
Dim uChooseColor As ChooseColorType
Dim CustomColors(15) As Long
Dim sArray() As String
Dim i As Long
'
msColorTitle = Title
'
' Setup custom colors.
sArray = Split(CustomColorsHex, ",")
If UBound(sArray) = 15 Then
For i = 0 To 15
CustomColors(i) = Val("&h" & sArray(i))
Next i
End If
'
uChooseColor.hWndOwner = hWndOwner
uChooseColor.lpCustColors = VarPtr(CustomColors(0))
uChooseColor.flags = CC_ENABLEHOOK Or CC_FULLOPEN
uChooseColor.hInstance = App.hInstance
uChooseColor.lStructSize = LenB(uChooseColor)
uChooseColor.lpfnHook = ProcedureAddress(AddressOf ColorHookProc)
'
ColorDialogSuccessful = False
If ChooseColorAPI(uChooseColor) = 0 Then
Exit Function
End If
If uChooseColor.rgbResult > &HFFFFFF Then Exit Function
'
ColorDialogColor = uChooseColor.rgbResult
NewColor = uChooseColor.rgbResult
ColorDialogSuccessful = True
ShowColorDialog = True
'
' Return custom colors.
ReDim sArray(15)
For i = 0 To 15
sArray(i) = Hex$(CustomColors(i))
Next i
CustomColorsHex = Join(sArray, ",")
End Function
Private Function ColorHookProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_SHOWWINDOW Then
SetWindowText hWnd, msColorTitle
ColorHookProc = 1&
End If
'
If uMsg = WM_LBUTTONDBLCLK Then
'
' If we're on a hWnd with text, we probably should ignore the double-click.
GetCursorPos pt32
ScreenToClient hWnd, pt32
'
If WindowText(ChildWindowFromPointEx(hWnd, pt32.X, pt32.Y, 0&)) = vbNullString Then
' For some reason, this SetFocus is necessary for the dialog to receive keyboard input under certain circumstances.
SetFocusTo hWnd
' Build EnterKeyDown & EnterKeyDown events.
muEvents(0).wVK = vbKeyReturn: muEvents(0).dwFlags = KEYEVENTF_KEYDOWN: muEvents(0).dwType = INPUT_KEYBOARD
muEvents(1).wVK = vbKeyReturn: muEvents(1).dwFlags = KEYEVENTF_KEYUP: muEvents(1).dwType = INPUT_KEYBOARD
' Put it on buffer.
SendInput 2&, muEvents(0), Len(muEvents(0))
ColorHookProc = 1&
End If
End If
End Function
Private Function ProcedureAddress(AddressOf_TheProc As Long)
ProcedureAddress = AddressOf_TheProc
End Function
Private Function WindowText(hWnd As Long) As String
WindowText = Space$(GetWindowTextLength(hWnd) + 1)
WindowText = Left$(WindowText, GetWindowText(hWnd, WindowText, Len(WindowText)))
End Function
Public Sub SetWindowText(hWnd As Long, sText As String)
SendMessageWLong hWnd, WM_SETTEXT, 0&, StrPtr(sText)
End Sub
Code:
Option Explicit
'
Dim msOurCustomColors As String
'
Private Sub Form_Click()
ShowColorDialog Me.hWnd, , "Pick a color for background", msOurCustomColors
If ColorDialogSuccessful Then Me.BackColor = ColorDialogColor
End Sub
Elroy