VBA and Colorwheel

[lwm]

I need a code example to allow the user to p;ick a color from within the
excel color wheel using VBA.

I have not been able to find one so far.
Thanks

 

[Gord Dibben]

Sub Foo()
Application.Dialogs(xlDialogPatterns).Show
End Sub

Will pop up the color picker dialog and color the selection with whatever color
is picked.


Gord Dibben MS Excel MVP

 

[lwm]

Thanks

This ansered my question but how do I use this to fill a variable if I put

x = Application.Dialogs(xlDialogPatterns).Show
msgbox x

I recieve true. I need to be able to use the variable in other statemnts
like changing font color.

 

[Jim Thomlinson]

There is no easy way to directly do what you ask. The show method takes a
number of arguments but I believe taht the argument are passed in by value
and not bey reference so they are not modified when the code is execulted.
The argument for the colour is Arg3 so if you execute the code like this then
No colour is always the default selection...

Application.Dialogs(xlDialogPatterns).Show Arg3:=0

You cna however get the colour indirectly. Since the dialog colours the
active cell you just need to read the colour of the cell immediatly following
the colour selection. So perhaps something like this...

dim x as long
dim y as long

x = activecell.interior.colorindex
Application.Dialogs(xlDialogPatterns).Show Arg3:=0
y = activecell.interior.colorindex
activecell.interior.colorindex = x

The only trick here is to make sure that only one cell is selected when this
code is run...

 

[lwm]

If I use this code

Sub Foo()
Dim x As Integer
Dim y As Integer

x = ActiveCell.Interior.ColorIndex
Application.Dialogs(xlDialogPatterns).Show Arg3:=0
y = ActiveCell.Interior.ColorIndex
ActiveCell.Interior.ColorIndex = x
Range("b5").Select

Selection.Font.ColorIndex = x
End Sub

I get the infamous 1004 on the Selection.Font.ColorIndex = x

If I use double instead of integer for the dim I get the 1004 error at
ActiveCell.Interior.ColorIndex = x


I want to change the font color at b5.

Thanks

 

[Jim Thomlinson]

You want to set it to y and not x. Give this a try...

Sub Foo()
Dim x As Integer
Dim y As Integer

x = ActiveCell.Interior.ColorIndex 'Store original color
Application.Dialogs(xlDialogPatterns).Show Arg3:=0
y = ActiveCell.Interior.ColorIndex 'Get selected color
ActiveCell.Interior.ColorIndex = x 'Restore original color
Range("b5").Font.ColorIndex = y 'Set font to selected color

End Sub

 

[RB Smissaert]

Try this code, all in a normal module:


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


RBS

 

[lwm]

Thanks

That works

You want to set it to y and not x. Give this a try...

Sub Foo()
Dim x As Integer
Dim y As Integer

x = ActiveCell.Interior.ColorIndex 'Store original color
Application.Dialogs(xlDialogPatterns).Show Arg3:=0
y = ActiveCell.Interior.ColorIndex 'Get selected color
ActiveCell.Interior.ColorIndex = x 'Restore original color
Range("b5").Font.ColorIndex = y 'Set font to selected color

End Sub

 

[lwm]

Rb

This works but is way beyond my current understanding. I will study it and
see if I can figure it out.

Thanks

 

[RB Smissaert]

I don't think I understand all myself, but you don't have to.
Application.Dialogs(xlDialogPatterns).Show does probably exactly the same
under the bonnet. Using the API gives you more flexibility, but if you don't
need it then I would go with the Application.Dialogs

RBS