 Just
as the GetOpen/GetSaveFileName APIs provide for inserting a hook against
the file dialog's creation, so too does the ChooseColor API.To take advantage
of the hooking mechanism provided in the dialog, the CC_ENABLEHOOK flag
is added to Flags parameter, pointing the lpfnHook to the AddressOf a
hook procedure we provide. Following the creation of the dialog, the
dialog sends the WM_INITDIALOG to the hook indicating the dialog is ready
to display configured according to the specifications made in the passed
CHOOSECOLOR structure. On receipt of the message, we have the opportunity
to tweak elements of dialog, as the illustrations shows - changing the
captions on the OK, Cancel, Define Colors and Add Colors buttons. In
addition, the code below correctly centres the dialog on the screen
regardless of whether the dialog was displayed normally or fully open.
|
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WM_INITDIALOG As Long = &H110
'ChooseColor Dialog component control ID's
'dialog buttons
Private Const CTLID_BTN_OK As Long = 1
Private Const CTLID_BTN_CANCEL As Long = 2
Private Const CTLID_BTN_ADDTOCUSTOMCOLORS As Long = &H2C8
Private Const CTLID_BTN_DEFINECUSTOMCOLORS As Long = &H2CF
'labels
Private Const CTLID_LABEL_HUE As Long = &H2D3
Private Const CTLID_LABEL_SAT As Long = &H2D4
Private Const CTLID_LABEL_LUM As Long = &H2D5
Private Const CTLID_LABEL_RED As Long = &H2D6
Private Const CTLID_LABEL_BLUE As Long = &H2D7
Private Const CTLID_LABEL_GREEN As Long = &H2D8
'text boxes
Private Const CTLID_VALUE_HUE As Long = &H2BF
Private Const CTLID_VALUE_SAT As Long = &H2C0
Private Const CTLID_VALUE_LUM As Long = &H2C1
Private Const CTLID_VALUE_RED As Long = &H2C2
Private Const CTLID_VALUE_BLUE As Long = &H2C3
Private Const CTLID_VALUE_GREENE As Long = &H2C4
'palettes / selectors
Private Const CTLID_PALETTE_BASICCOLORS As Long = &H2D0
Private Const CTLID_PALETTE_CUSTOM_COLORS As Long = &H2D1
Private Const CTLID_PALETTE_CUSTOMRAINBOW As Long = &H2C6
Private Const CTLID_PALETTE_CUSTOMDENSITY As Long = &H2BE
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetDlgItem Lib "user32" _
(ByVal hDlg As Long, _
ByVal nIDDlgItem As Long) As Long
Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Function FARPROC(ByVal pfn As Long) As Long
'Procedure that receives and returns
'the passed value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Function ChooseColorProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim rc As RECT
Dim hwndctl As Long
Dim scrWidth As Long
Dim scrHeight As Long
Dim dlgWidth As Long
Dim dlgHeight As Long
Select Case uMsg
Case WM_INITDIALOG
'centre the dialog on the screen
Call GetWindowRect(hwnd, rc)
scrWidth = (Screen.Width \ Screen.TwipsPerPixelX)
scrHeight = (Screen.Height \ Screen.TwipsPerPixelY)
dlgWidth = rc.Right - rc.Left
dlgHeight = rc.Bottom - rc.Top
Call MoveWindow(hwnd, (scrWidth - dlgWidth) \ 2, _
(scrHeight - dlgHeight) \ 2, _
dlgWidth, _
dlgHeight, 1)
'customize the dialog caption
Call SetWindowText(hwnd, "VBnet ChooseColor Demo")
'alter the text on the OK, CANCEL
'Define and Add buttons
hwndctl = GetDlgItem(hwnd, CTLID_BTN_OK)
Call SetWindowText(hwndctl, "Apply")
hwndctl = GetDlgItem(hwnd, CTLID_BTN_CANCEL)
Call SetWindowText(hwndctl, "Bail Out")
hwndctl = GetDlgItem(hwnd, CTLID_BTN_CANCEL)
Call SetWindowText(hwndctl, "Bail Out")
hwndctl = GetDlgItem(hwnd, CTLID_BTN_DEFINECUSTOMCOLORS)
Call SetWindowText(hwndctl, "Create a new color >>")
hwndctl = GetDlgItem(hwnd, CTLID_BTN_ADDTOCUSTOMCOLORS)
Call SetWindowText(hwndctl, "Add as a new color")
ChooseColorProc = 1
Case Else
End Select
End Function
|
Option Explicit Option Explicit
'static array to contain the custom
'colours selected by the user
Private dwCustClrs(0 To 15) As Long
'ChooseColor structure flag constants
Private Const CC_RGBINIT As Long = &H1
Private Const CC_FULLOPEN As Long = &H2
Private Const CC_PREVENTFULLOPEN As Long = &H4
Private Const CC_ENABLEHOOK As Long = &H10
Private Const CC_SOLIDCOLOR As Long = &H80
Private Const CC_ANYCOLOR As Long = &H100
Private Type CHOOSECOLORSTRUCT
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 Declare Function ChooseColor Lib "comdlg32.dll" _
Alias "ChooseColorA" _
(lpcc As CHOOSECOLORSTRUCT) As Long
Private Sub Form_Load()
Dim cnt As Long
'populate the custom colours
'with a series of gray shades
For cnt = 240 To 15 Step -15
dwCustClrs((cnt \ 15) - 1) = RGB(cnt, cnt, cnt)
Next
'initialize controls
Option1.Caption = "Display normally"
Option1.Value = True
Option2.Caption = "Display with Define Custom Colors open"
Option3.Caption = "Disable Define Custom Colors button"
Check1.Caption = "Specify initial colour is form backcolor"
Check2.Caption = "Hook and centre on screen"
Command1.Caption = "Choose Color"
End Sub
Private Sub Command1_Click()
Dim cc As CHOOSECOLORSTRUCT
Dim r As Long
Dim g As Long
Dim b As Long
With cc
'base flag
.flags = CC_ANYCOLOR
'show custom colours?
If Option2.Value = True Then .flags = .flags Or CC_FULLOPEN
'prevent display of custom colours?
If Option3.Value = True Then .flags = .flags Or CC_PREVENTFULLOPEN
'initial colour is specified?
If Check1.Value = 1 Then
.flags = .flags Or CC_RGBINIT
.rgbResult = Form1.BackColor
End If
'hook the dialog?
If Check2.Value = 1 Then
.flags = .flags Or CC_ENABLEHOOK
.lpfnHook = FARPROC(AddressOf ChooseColorProc)
End If
'size of structure
.lStructSize = Len(cc)
'owner of the dialog
.hwndOwner = Me.hwnd
'assign the custom colour selections
.lpCustColors = VarPtr(dwCustClrs(0))
End With
If ChooseColor(cc) = 1 Then
'assign the selected colour
'as the form background
Me.BackColor = cc.rgbResult
'bonus .. assure the text remains
'readable regardless of colour
'by splitting out the respective
'RGB values, and adjusting the text
'colour to contrast
Call GetRBGFromCLRREF(cc.rgbResult, r, g, b)
Call UpdateControlShadeSelection(r, g, b)
End If
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub UpdateControlShadeSelection(r As Long, g As Long, b As Long)
Dim ctlcolor As Long
Dim ctl As Control
'if the value of the colour passed
'(representing the current colour)
'is less than 128, show white text
'otherwise show black text
If (r < 128) And (g < 128) Or _
(g < 128) And (b < 128) Or _
(r < 128) And (b < 128) Then
ctlcolor = vbWhite
Else
ctlcolor = vbWindowText
End If
'set the option and check backcolor
'to the form backcolor, and the
'control's text to the contrasting
'shade
For Each ctl In Controls
If TypeOf ctl Is OptionButton Or _
TypeOf ctl Is CheckBox Then
ctl.BackColor = RGB(r, g, b)
ctl.ForeColor = ctlcolor
End If
Next
End Sub
Private Sub GetRBGFromCLRREF(ByVal clrref As Long, _
r As Long, g As Long, b As Long)
'pass a hex colour, return the rgb components
b = (clrref \ 65536) And &HFF
g = (clrref \ 256) And &HFF
r = clrref And &HFF
End Sub
|
