Derek Hart said:
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