Visual Basic Common Dialog Routines
ChooseColor: Centering and Customizing the ChooseColor Common Dialog
     
Posted:   Friday March 29, 2002
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB4-32, Windows 95
Revised with:   VB6, Windows NT4; VB6,  Windows XP
OS restrictions:   None
Author:   VBnet - Randy Birch
     
Related:   ChooseColor: Using the ChooseColor Common Dialog API
ChooseColor: Centering and Customizing the ChooseColor Common Dialog
     
 Prerequisites
VB5 / VB6.

(graphic in png format)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.

 BAS Module Code
Place the following code into the general declarations area of a bas module:

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
 Form Code
To a new project form add two command buttons (Command1, Command2), three option buttons (Option1, Option2, Option3), and a two checkboxes (Check1, Check2). Add the following code to the form:

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
 Comments

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright ©1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter