Get color code from button fill color on tool bar ?

[danial]

Sawasdee,

Could you help me to create VBA code for get the color code from fill color button on tools bar.

I want to painting in something cells with some condition.
firstly I was created that code.
but I want to fill the color as current color which displayed on "fill color button" on tools bar

how can I create code for get it.

For I = 1 To 10
If Cells(I, 1) = "X" Then Cells(I, 1).Interior.ColorIndex = 5
Next

Thanks in advance.

 

[Jaafar Tribak]

Danial,

The following code assumes the 'Fill Color' Button from the Formatting toolbar is on display and set the interior color of the ActiveCell to that which is currenly on display by the Button.

Place in Standard Module :

Option Explicit

Sub SetColorToCurrent(r As Range)

    Dim vColorsArray(1 To 40)
    Dim vToolTipArray(1 To 40)
    Dim sToolTipText As String
    Dim bytColorPos As Byte, i As Byte
    
    
    
    '\populate both arrays
    vColorsArray(1) = "0"
    vToolTipArray(1) = "Black"
    
    vColorsArray(2) = "3399"
    vToolTipArray(2) = "Brown"
    
    vColorsArray(3) = "3333"
    vToolTipArray(3) = "Olive Green"
    
    vColorsArray(4) = "3300"
    vToolTipArray(4) = "Dark Green"
    
    vColorsArray(5) = "663300"
    vToolTipArray(5) = "Dark Teal"
    
    vColorsArray(6) = "800000"
    vToolTipArray(6) = "Dark Blue"
    
    vColorsArray(7) = "993333"
    vToolTipArray(7) = "Indigo"
    
    vColorsArray(8) = "333333"
    vToolTipArray(8) = "Gray-80%"
    
    vColorsArray(9) = "80"
    vToolTipArray(9) = "Dark Red"
    
    vColorsArray(10) = "66FF"
    vToolTipArray(10) = "Orange"
    
    vColorsArray(11) = "8080"
    vToolTipArray(11) = "Dark Yellow"
    
    vColorsArray(12) = "8000"
    vToolTipArray(12) = "Green"
    
    vColorsArray(13) = "808000"
    vToolTipArray(13) = "Teal"
    
    vColorsArray(14) = "FF0000"
    vToolTipArray(14) = "Blue"
    
    vColorsArray(15) = "996666"
    vToolTipArray(15) = "Blue-Gray"
    
    vColorsArray(16) = "808080"
    vToolTipArray(16) = "Gray-50%"
    
    vColorsArray(17) = "FF"
    vToolTipArray(17) = "Red"
    
    vColorsArray(18) = "99FF"
    vToolTipArray(18) = "Light Orange"
    
    vColorsArray(19) = "CC99"
    vToolTipArray(19) = "Lime"
    
    vColorsArray(20) = "669933"
    vToolTipArray(20) = "Sea Green"
    
    vColorsArray(21) = "CCCC33"
    vToolTipArray(21) = "Aqua"
    
    vColorsArray(22) = "FF6633"
    vToolTipArray(22) = "Light Blue"
    
    vColorsArray(23) = "800080"
    vToolTipArray(23) = "Violet"
    
    vColorsArray(24) = "969696"
    vToolTipArray(24) = "Gray-40%"
    
    vColorsArray(25) = "FF00FF"
    vToolTipArray(25) = "Pink"
    
    vColorsArray(26) = "CCFF"
    vToolTipArray(26) = "Gold"
    
    vColorsArray(27) = "FFFF"
    vToolTipArray(27) = "Yellow"
    
    vColorsArray(28) = "FF00"
    vToolTipArray(28) = "Bright Green"
    
    vColorsArray(29) = "FFFF00"
    vToolTipArray(29) = "Turquoise"
    
    vColorsArray(30) = "FFCC00"
    vToolTipArray(30) = "Sky Blue"
    
    vColorsArray(31) = "663399"
    vToolTipArray(31) = "Plum"
    
    vColorsArray(32) = "C0C0C0"
    vToolTipArray(32) = "Gray-25%"
    
    vColorsArray(33) = "CC99FF"
    vToolTipArray(33) = "Rose"
    
    vColorsArray(34) = "99CCFF"
    vToolTipArray(34) = "Tan"
    
    vColorsArray(35) = "99FFFF"
    vToolTipArray(35) = "Light Yellow"
    
    vColorsArray(36) = "CCFFCC"
    vToolTipArray(36) = "Light Green"
    
    vColorsArray(37) = "FFFFCC"
    vToolTipArray(37) = "Light Turquoise"
    
    vColorsArray(38) = "FFCC99"
    vToolTipArray(38) = "Pale Blue"
    
    vColorsArray(39) = "FF99CC"
    vToolTipArray(39) = "Lavender"
    
    vColorsArray(40) = "FFFFFF"
    vToolTipArray(40) = "White"
    
    '\store the tooltips of all color controls
    '\located in the "Fill Color" ToolBar
    For i = 1 To 40
        vToolTipArray(i) = "Fill Color (" & vToolTipArray(i) & ")"
    Next
    
    '\get the current color tooltiptex
    sToolTipText = CommandBars.FindControl(Id:=1691).TooltipText
    
    '\handle the unique case of "No Fill"
    On Error Resume Next
    bytColorPos = WorksheetFunction.Match(sToolTipText, vToolTipArray(), 0)
    If Err <> 0 Then
        On Error GoTo 0
        r.Interior.ColorIndex = 0
        Exit Sub
    End If
    
    '\set the color of range(s)
    r.Interior.Color = hexTodec(vColorsArray(bytColorPos))

End Sub


'\convert hex to decimals
Private Function hexTodec(ByVal hex As String) As Double
  Dim f As Double
  Dim r As Double
  Dim B As String
  
  f = 1
  r = 0
  While Len(hex) > 0
    B = Mid(hex, Len(hex), 1)
    Select Case B
      Case "0" To "9"
           r = r + f * Val(B)
      Case Else
           r = r + f * (10 + Asc(B) - Asc("A"))
    End Select
    f = f * 16
    hex = Left(hex, Len(hex) - 1)
  Wend
  hexTodec = r
  
End Function

Run this Test in a Standard Module :

Sub Test()

    SetColorToCurrent ActiveCell

End Sub

Tested in XL2002.


Regards.

 

[danial]

Shukran = "Khob-koon" in thai lang.

I will try.

 

[danial]

thank a lot,

This is the heart of procedure.

sToolTipText = CommandBars.FindControl(ID:=1691).TooltipText

I'm tried with your code, Its work.
realy, we must get current color from "TooltipText" only?
So hard.

Shukran again

 

[Jaafar Tribak]

Hi Danial,

realy, we must get current color from "TooltipText" only?

Sorry I don't understand !

Regards.

 

[danial]

Sorry for my wrong communication.
I mean that any way for get properties of fill color.
How can I direct get color code?