Tab Color Choice From Form

[NMeeker]

I am using an Excel Form, and trying to make the user choose a color for a new tab they are creating. I am currently forcing an input box to pop up when the user adds a new worksheet. The user inputs a name and a new box will pop up asking the user to select a color.

I can get the color box to come up using

Application.Dialogs.Item(xlDialogColorPalette).Show     ' -- 56 colors

But I can not get the tab color to change to the color chosen...
Any suggestions to retrieve the information from the ColorPalette box?

I also know that this code:

Worksheets(a).Tab.ColorIndex = 56

Will change the selected "a" tab color to color "56" but I dont know how to retrieve a color from the color palette and insert it where the "56" is...

Any help retrieving color from palette?


Also, is there any othere version of a color palette, that I could show the user? and what would the vba code be for that?

 

[Tom Urtis]

Either of these 2 links should help you. All you'd need to do to modify them for your situation is to direct the selected color to affect the sheet tab instead of a cell.

http://j-walk.com/ss/excel/tips/tip49.htm

http://www.mrexcel.com/forum/showthread.php?t=66008

 

[Kenneth Hobson]

Put this into a Module as NateO posted in:
http://www.mrexcel.com/forum/showthread.php?t=31123
http://www.mrexcel.com/forum/showthread.php?t=34891

Ivan F Moala has similar code in the link that Tom posted.

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias _
    "ChooseColorA" (pChoosecolor As ChooseColor) As Long

Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long


Private Type ChooseColor
         lStructSize As Long
         hwndOwner As Long
         hInstance As Long
         rgbResult As Long
         lpCustColors As String
         flags As Long
         lCustData As Long
         lpfnHook As Long
         lpTemplateName As String
End Type


Function ShowColor() As Long
         Dim ChooseColorStructure As ChooseColor
         Dim Custcolor(16) As Long
         Dim lReturn As Long
         Dim CustomColors As Long
         ChooseColorStructure.lStructSize = Len(ChooseColorStructure)
         ChooseColorStructure.hwndOwner = FindWindow("XLMAIN", Application.Caption)
         ChooseColorStructure.hInstance = 0
         ChooseColorStructure.lpCustColors = StrConv(CustomColors, vbUnicode)
         ChooseColorStructure.flags = 0
         If ChooseColor(ChooseColorStructure) <> 0 Then
             ShowColor = ChooseColorStructure.rgbResult
             CustomColors = StrConv(ChooseColorStructure.lpCustColors, vbFromUnicode)
         Else
             ShowColor = -1
         End If
End Function

To use it, something like this at the end of that Module or in a Another or however you like:

Sub SetMyTabColor()
  Dim newSheetName As String
  On Error GoTo Again
  Worksheets.Add , Worksheets(Worksheets.Count)
NameSheet:
  newSheetName = InputBox("Enter a new sheet name.", "New Sheet Name")
  ActiveSheet.Name = newSheetName
  ActiveSheet.Tab.Color = ShowColor
  
  Exit Sub
Again:
  If newSheetName = vbNullString Then
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    Exit Sub
  End If
  MsgBox "There was a problem naming your sheet: " & newSheetName, vbCritical, _
    "Try Again"
  GoTo NameSheet
End Sub

 

[NMeeker]

Well, I have played around with each of these options so far. Currently, of these, I like Kenneth's Code. However, I am having troubles with it every time I try to use the custom colors. I am getting a type mismatch Leading to this line in Kenneth's first piece of code:

             CustomColors = StrConv(ChooseColorStructure.lpCustColors, vbFromUnicode)

To call the code I am using:

Sub NewCopyOfMaster()
   Dim a As String, response As Long
NameSheet:
   a = Application.InputBox( _
      Prompt:="Enter Name of New Rope", _
      Title:="Name of New Rope?", Left:=1, Top:=1)
 If a = "False" Then
    Exit Sub
Else:
   If a <> "" Then
     response = MsgBox("Are you sure you would like to add a new rope called " & a, _
     vbYesNo, Title:="Add New Rope?")
     If response = vbYes Then
        Sheets("Master").Copy After:=Sheets(Me.Sheets.Count)
        Sheets(Me.Sheets.Count).Visible = True
        Sheets(Me.Sheets.Count).Name = a
        Worksheets(a).Range("J7").Value = a
        Worksheets(a).Tab.COLOR = ShowColor
        
     End If
     Else:  MsgBox "Please enter a name for your new Rope to continue.", vbCritical, _
            "Try Again"
            GoTo NameSheet
   End If
 End If
End Sub

Is there a way to get the custom colors to work without having to catch the error that is inevitable and and force the user to try again until they finally choose an acceptable color?

 

[Kenneth Hobson]

I don't have time to tweak this just yet. You might find a commandbars approach more workable.

Sub SetTabColor()
  Dim r As Range, rc As Long
  Set r = Range("h100")
  r.Select
  rc = r.Interior.Color
  With Application.CommandBars("Fill Color")
    .Visible = True
    .Position = msoBarFloating
    .Left = r.Offset(0, 1).Left
    .Top = r.Top - r.Top
    Do
      DoEvents
    Loop Until .Visible = False
  End With
  ActiveSheet.Tab.ColorIndex = r.Interior.ColorIndex
  r.Interior.Color = rc
End Sub

 

[NMeeker]

Thanks I've got it working great now.

 

[Kenneth Hobson]

Can you post the code that works or explain what approach was best for you?

 

[NMeeker]

Certainly!!! After a bunch of searching and a little directional help from you guys this is what I ended up using:

Function GetColorindex(Optional Text As Boolean = False) As Long

Dim rngCurr As Range

Set rngCurr = Selection
Application.ScreenUpdating = False
Range("A1").Select
Application.Dialogs(xlDialogPatterns).Show
GetColorindex = ActiveCell.Interior.Colorindex
If GetColorindex = xlColorIndexAutomatic And Not Text Then
GetColorindex = xlColorIndexNone
End If
ActiveCell.Interior.Colorindex = xlColorIndexNone
rngCurr.Select
Set rngCurr = ActiveSheet.UsedRange
Application.ScreenUpdating = True
End Function

It brings up a color pallet for a cell, then changes the color of that cell, references it, then clears the color. and returns your cursor to where it began. I set the cell to A1 because I have no formating in that cell.

The only downside to using this to add color to a tab, is that the heading of the color pallet says "Cell Color" instead of "Tab color" which I think is a very small fee for something that works so well for me.

 

[jfbuller]

A slightly different need led me to this post, and eventually I arrived at a solution. Having sorted it out I thought I should contribute. This was a useful solution for allowing the user to choose a color for a selected range. In this case if one cell meets a text criteria and another cell meets a numeric criteria then the user can choose from 40 colors in the command bar to highlight the values exceeding the numeric criteria.

Sub flag_values()
   
   With ActiveSheet
 
Dim i As Integer
Dim param As String
Dim ValuesToSelect As String
Dim val As Variant
Dim rngParam As range
Dim rCell As range
    
    'Set dynamic range
Set rngParam = range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    
    'Prompts user to enter text parameter to select by
param = Application.InputBox("Input Parameter", "Parameter Selection", , , , , , 2)
        If param = vbNullString Then Exit Sub
    'Prompts user to enter number value to select by
val = Application.InputBox("Input Guideline Value", "Guideline", , , , , , 1)
    If val = vbNullString Then Exit Sub
 
i = 1
    'Searches cells from column "D" resembling whatever was entered in parameter prompt
    'And searches cells from column "I" for values >= the numeric value entered
    'and connects any cells found in column "I" into a string
For Each rCell In rngParam
    If Cells(i, "D") Like "*" & param & "*" And Cells(i, "I") >= val Then
        If ValuesToSelect <> "" Then ValuesToSelect = ValuesToSelect & ","
        ValuesToSelect = ValuesToSelect & "I" & i
    End If
i = i + 1
Next rCell
       
    'Selects all values satisfying the entered requirements
      
End With
       'in case there are no values exceeding the numeric criteria
 On Error GoTo ErrMsg
       
       'Selects all values satisfying the entered requirements
        ActiveSheet.range(ValuesToSelect).Select
        
    'Opens the 40 color swatch command bar
        Application.CommandBars("Fill Color").Visible = True
    'Simply click the color you want and the filtered cells will change to it.
 
End With
Exit Sub
 
ErrMsg:
MsgBox "No Exceedances!"
 
End Sub

Thanks to the forum members!