Can I adapt this to retrun a colour RGB value to a specific cell? I'm trying
to select a colour from a picker and then return its rgb value ie FFFF00 to
a cell. I'm new to vba with excel and so many coaching would be great. thanks

Option Explicit
Declare Function GetSysColor Lib "user32" (ByVal nIndex 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 ChooseColor Lib "comdlg32.dll" _
Alias "ChooseColorA" _
(lpcc As CHOOSECOLORSTRUCT) As Long

Private Const WM_INITDIALOG As Long = &H110

'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_ENABLEHOOK As Long = &H10
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 strClrPickerTitle As String

Function GetColour(lStartColour As Long, _
strWindowTitle As String, _
adjustText As Boolean) As Long

Dim CC As CHOOSECOLORSTRUCT
Dim CNT As Long

strClrPickerTitle = strWindowTitle

'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 CNT

With CC
'base flag
.flags = CC_ANYCOLOR
.flags = .flags Or CC_FULLOPEN
.flags = .flags Or CC_RGBINIT
.rgbResult = lStartColour
.flags = .flags Or CC_ENABLEHOOK
.lpfnHook = FARPROC(AddressOf ChooseColorProc)
'size of structure
.lStructSize = Len(CC)
'assign the custom colour selections
.lpCustColors = VarPtr(dwCustClrs(0))
End With

If ChooseColor(CC) = 1 Then
'return the long colour
'----------------------
GetColour = CC.rgbResult
Else
'return the colour you started with
'----------------------------------
GetColour = lStartColour
End If

End Function

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

Function ChooseColorProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

If uMsg = WM_INITDIALOG Then

'customize the dialog caption
Call SetWindowText(hWnd, strClrPickerTitle)

ChooseColorProc = 1

End If

End Function

Sub test()

MsgBox GetColour(0, "just testing", True)

End Sub

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/201005/1