A
a1k1do via OfficeKB.com
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
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