Color Dialog Picker

[Derek Hart]

I've been searching for API code (that works) to pop up a color dialog
picker. Thought it would be easy to find. I would appreciate a push in the
right direction for this code...

Derek

 

[Daniel Pineault]

You may be able to modify the color example found at

http://www.cardaconsultants.com/en/msaccess.php?lang=en&id=0000000007

to suit your needs.

Also, although I have never used it, you should take a look at

http://www.mvps.org/access/api/api0060.htm

 

[Stuart McCall]

I've been searching for API code (that works) to pop up a color dialog
picker. Thought it would be easy to find. I would appreciate a push in
the right direction for this code...

Derek

Paste this code into a new standard module:

''' START CODE '''
Option Compare Database
'
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 String
End Type
'
Private Declare Function ChooseColorA Lib "comdlg32.dll" (pChoosecolor As
CHOOSECOLOR) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, hpvSource
As Any, ByVal cbCopy As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long,
ByVal dwBytes As Long) As Long
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 Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GHND As Long = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const GMEM_SIZE As Long = &H40
'
Public Const CC_RGBINIT As Long = &H1 'Sets initial dialog
selection to colour passed
Public Const CC_FULLOPEN As Long = &H2 'Opens dialog with custom
colour panel visible
Public Const CC_PREVENTFULLOPEN As Long = &H4 'Prevents user from
modifying custom colours

Function SelectColour(ByRef colour As Long, Optional ByVal pFlags, Optional
ByVal fhWnd) As Boolean
' Returns True if user clicked Ok. Chosen colour is
' passed back by reference in the colour parameter.
' Returns False if user clicked Cancel, close, or
' an error occurred.

Static arrayCustom(0 To 15) As Long
Static addrCustom As Long
Dim clr As CHOOSECOLOR

If addrCustom = 0 Then
' If array not initialised, fill with white
For i& = 0 To 15
arrayCustom(i) = &HFFFFFF
Next
End If
' Allocate global memory block
hMem& = GlobalAlloc(GHND, GMEM_SIZE)
If hMem = 0 Then Exit Function
' Lock it for subsequent use
addrCustom = GlobalLock(hMem)
If addrCustom = 0 Then Exit Function
' Copy array to ram
RtlMoveMemory ByVal addrCustom, arrayCustom(0), GMEM_SIZE
'
' Handle optional parameters
If IsMissing(fhWnd) Then fhWnd = Application.hWndAccessApp
If IsMissing(pFlags) Then pFlags = CC_RGBINIT
'
With clr
.lStructSize = Len(clr)
.hWndOwner = fhWnd
.lpCustColors = addrCustom
.rgbResult = colour
.Flags = pFlags
End With
SelectColour = ChooseColorA(clr)
' Return selected value thru colour parameter
colour = clr.rgbResult
'
' Copy ram to array
RtlMoveMemory arrayCustom(0), ByVal addrCustom, GMEM_SIZE
' and free it up
GlobalUnlock hMem
GlobalFree hMem
End Function
''' END CODE '''

Call it like this:

If SelectColour(ChosenColor) Then
MsgBox "Color chosen was: " & ChosenColor
Else
MsgBox "User pressed Cancel"
End If

 

[Stuart McCall]

Paste this code into a new standard module:

''' START CODE '''
Option Compare Database
'
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 String
End Type
'
Private Declare Function ChooseColorA Lib "comdlg32.dll" (pChoosecolor As
CHOOSECOLOR) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any,
hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long,
ByVal dwBytes As Long) As Long
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 Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GHND As Long = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const GMEM_SIZE As Long = &H40
'
Public Const CC_RGBINIT As Long = &H1 'Sets initial dialog
selection to colour passed
Public Const CC_FULLOPEN As Long = &H2 'Opens dialog with custom
colour panel visible
Public Const CC_PREVENTFULLOPEN As Long = &H4 'Prevents user from
modifying custom colours

Function SelectColour(ByRef colour As Long, Optional ByVal pFlags,
Optional ByVal fhWnd) As Boolean
' Returns True if user clicked Ok. Chosen colour is
' passed back by reference in the colour parameter.
' Returns False if user clicked Cancel, close, or
' an error occurred.

Static arrayCustom(0 To 15) As Long
Static addrCustom As Long
Dim clr As CHOOSECOLOR

If addrCustom = 0 Then
' If array not initialised, fill with white
For i& = 0 To 15
arrayCustom(i) = &HFFFFFF
Next
End If
' Allocate global memory block
hMem& = GlobalAlloc(GHND, GMEM_SIZE)
If hMem = 0 Then Exit Function
' Lock it for subsequent use
addrCustom = GlobalLock(hMem)
If addrCustom = 0 Then Exit Function
' Copy array to ram
RtlMoveMemory ByVal addrCustom, arrayCustom(0), GMEM_SIZE
'
' Handle optional parameters
If IsMissing(fhWnd) Then fhWnd = Application.hWndAccessApp
If IsMissing(pFlags) Then pFlags = CC_RGBINIT
'
With clr
.lStructSize = Len(clr)
.hWndOwner = fhWnd
.lpCustColors = addrCustom
.rgbResult = colour
.Flags = pFlags
End With
SelectColour = ChooseColorA(clr)
' Return selected value thru colour parameter
colour = clr.rgbResult
'
' Copy ram to array
RtlMoveMemory arrayCustom(0), ByVal addrCustom, GMEM_SIZE
' and free it up
GlobalUnlock hMem
GlobalFree hMem
End Function
''' END CODE '''

Call it like this:

If SelectColour(ChosenColor) Then
MsgBox "Color chosen was: " & ChosenColor
Else
MsgBox "User pressed Cancel"
End If

I should have done a bit of reformatting first. The Declare Function lines
all need to be unwrapped, as does the Function SelectColor line.

 

[Stephen Lebans]

See:
http://www.lebans.com/fontcolordialog.htm
ChooseFontColorDialog.zip is a database containing functions showing how to
call the API Font and Color Dialogs.

NEW - Jan. 28/2000 The Font and Color Dialogs are very easy to call. Here is
the code behind the Command Button on the sample Form. For this sample we
pass a TextBox that the function fills in with the Name and Size of the Font
selected by the user.

Private Sub CmdChooseFont_Click()
Dim lngRet As Boolean
' Pass the TextBox Control to the function
lngRet = test_DialogFont(Me.textCtl)
End Sub

Based on original code written by Terry Kreft.
--

HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.