Clare.Moe said:
Thanks again, Peter. I've now looked at the discussion you
referenced .... more than I'm ready to dig into right now <g>
You were more curious than I expected
Hope you have a good reason for this but try the following -
Option Explicit
'' Set displayed colour in the Fill or Font dropdown
'' pmbthornton at gmail com
Private Declare Function SetCursorPos Lib "user32" ( _
ByVal x As Long, ByVal y As Long) As Long
Private Declare Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Sub SetPaletteColor(FillOrFont As String, clrIndex As Long)
'FillOrFont: "Fill" or "Font"
'clrIndex: 1-56 or 0
Dim x As Long, y As Long, b As Boolean
Dim rw As Long, cl As Long
Dim sName As String
Dim va(0 To 4)
Static cbr As CommandBar
Static oldLeft As Long, oldTop As Long, bVis As Boolean
Static rng As Range
Static oldFill As Long, oldFont As Long
If clrIndex = -1 Then ' called with OnTime
'dont know why but seems can only reset old cell colours with Ontime
If Not rng Is Nothing Then
ActiveCell.Interior.ColorIndex = oldFill
ActiveCell.Font.ColorIndex = oldFont
rng.Select
End If
' also if want to reset the dropdown it must be done with Ontime
If Not cbr Is Nothing Then
With cbr
.Visible = bVis
.Left = oldLeft
.Top = oldTop
End With
End If
Set cbr = Nothing
Set rng = Nothing
Exit Sub
End If
sName = IIf(FillOrFont = "Font", "Font Color", "Fill Color")
If TypeName(Selection) <> "Range" Then
MsgBox "Select one or more cells", , "SetPaletteColor"
Exit Sub
End If
Set rng = Selection
' ensure only one cell selected
ActiveCell.Select
' trap the old colour
oldFill = ActiveCell.Interior.ColorIndex
oldFont = ActiveCell.Font.ColorIndex
If clrIndex < 1 Or clrIndex > 56 Then ' automatic/none
x = 82: y = 35 ' pixels to center of the auto/no-fill
Else
va(0) = Array(1, 53, 52, 51, 49, 11, 55, 56)
va(1) = Array(9, 46, 12, 10, 14, 5, 47, 16)
va(2) = Array(3, 45, 43, 50, 42, 41, 13, 48)
va(3) = Array(7, 44, 6, 4, 8, 33, 54, 15)
va(4) = Array(38, 40, 36, 35, 34, 37, 39, 2)
'first get the row/col location of the colorIndex in the palette
For cl = 0 To 7
For rw = 0 To 4
If clrIndex = va(rw)(cl) Then
b = True
Exit For
End If
Next
If b Then Exit For
Next
cl = cl + 1
rw = rw + 1
' pixels to centre of the appropriate colour in the palette
x = cl * 18
y = 40 + rw * 18
End If
Set cbr = Application.CommandBars(sName)
With cbr
' make the fill or font dropdown palette visible, move to Top-Left
bVis = .Visible
.Visible = True
oldLeft = .Left
oldTop = .Top
.Left = 0
.Top = 0
End With
' move mouse over the colour
SetCursorPos x, y
' simulate mouse down & up
Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
'for some weird reason the old colour does not reapplied,
'hence the OnTime
ActiveCell.Interior.ColorIndex = oldFill
ActiveCell.Font.ColorIndex = oldFont
End Sub
Sub test()
Dim sMacro As String
' Application.ScreenUpdating = False ' doesn't seem to help
SetPaletteColor FillOrFont:="Font", clrIndex:=3
sMacro = "' SetPaletteColor " & _
Chr(34) & "" & Chr(34) & ", " & -1 & "' "
Application.OnTime Now, sMacro ' reset cell colour & the dropdown
' Do not attempt to change both Fill & Font dropdowns at the same time
' as the OnTime(s) only fire after all normal code completes.
End Sub
Can't avoid the dropdown flashing momentarirly to topleft of screeen. It
should be possible to re-work some aspects to avoid the current need to
reset the dropdown and cell colour with OnTime (I ran out of time!).
Regards,
Peter T
