Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

'-----------------------------------------------------------------------------------------
' Copyright ©1996-2008 VBnet, Randy Birch. All Rights Reserved Worldwide.
'        Terms of use http://vbnet.mvps.org/terms/pages/terms.htm
'-----------------------------------------------------------------------------------------

'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_PREVENTFULLOPEN As Long = &H4
Private Const CC_SOLIDCOLOR      As Long = &H80
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 Declare Function ChooseColor Lib "comdlg32.dll" _
   Alias "ChooseColorA" _
  (lpcc As CHOOSECOLORSTRUCT) As Long


Private Sub Form_Load()
   
  'initialize the custom colours
  'with a series of gray shades
   Dim cnt As Long
   For cnt =  240  To  15  Step - 15 
      dwCustClrs((cnt \  15 ) -  1 ) = RGB(cnt, cnt, cnt)
   Next
      
  'initialize controls
   Option1.Caption = "Display normally"
   Option1.Value = True
   Option2.Caption = "Display with Define Custom Colors open"
   Option3.Caption = "Disable Define Custom Colors button"
   Check1.Caption = "Specify initial colour is form BackColor"
   Command1.Caption = "Choose Color"
   
End Sub


Private Sub Command1_Click()

   Dim cc As CHOOSECOLORSTRUCT
   Dim r As Long
   Dim g As Long
   Dim b As Long
   
   With cc
   
     'set the flags based on the
     'check and option buttons
      .flags = CC_ANYCOLOR
      If Option2.Value = True Then .flags = .flags Or CC_FULLOPEN
      If Option3.Value = True Then .flags = .flags Or CC_PREVENTFULLOPEN
      If Check1.Value =  1  Then
         .flags = .flags Or CC_RGBINIT
         .rgbResult = Form1.BackColor
      End If
   
      'size of structure
      .lStructSize = Len(cc)
      
      'owner of the dialog
      .hwndOwner = Me.hWnd
      
      'assign the custom colour selections
      .lpCustColors = VarPtr(dwCustClrs( 0 ))
      
   End With
   
   If ChooseColor(cc) =  1  Then
   
     'assign the selected colour
     'as the form background
      Me.BackColor = cc.rgbResult
      
     'bonus .. assure the text remains
     'readable regardless of colour
     'by splitting out the respective
     'RGB values, and adjusting the text
     'colour to contrast
      Call GetRBGFromCLRREF(cc.rgbResult, r, g, b)
      Call UpdateControlShadeSelection(r, g, b)
   
   End If

End Sub


Private Sub UpdateControlShadeSelection(r As Long, g As Long, b As Long)

   Dim ctlcolor As Long
   Dim ctl As Control
   
  'if the value of the colour passed
  '(representing the current colour)
  'is less than 128, show white text
  'otherwise show black text
   If (r <  128 ) And (g <  128 ) Or _
      (g <  128 ) And (b <  128 ) Or _
      (r <  128 ) And (b <  128 ) Then
   
      ctlcolor = vbWhite
   Else
      ctlcolor = vbWindowText
   End If
   
  'set the option and check backcolor
  'to the form backcolor, and the
  'control's text to the contrasting
  'shade
   For Each ctl In Controls
      
      If TypeOf ctl Is OptionButton Or _
         TypeOf ctl Is CheckBox Then
         ctl.BackColor = RGB(r, g, b)
         ctl.ForeColor = ctlcolor
      End If
      
   Next
   
End Sub


Private Sub GetRBGFromCLRREF(ByVal clrref As Long, _
                             r As Long, g As Long, b As Long)
    
  'pass a hex colour, return the rgb components
   b = (clrref \  65536 ) And &HFF
   g = (clrref \  256 ) And &HFF
   r = clrref And &HFF
   
End Sub


Private Sub Command2_Click()

   Unload Me

End Sub

Me.BackColor = cc.rgbResult

Application.Dialogs.Item(xlDialogColorPalette).Show

Me.Application.ActiveCell.Interior.ColorIndex = GetColorindex(Me.Application.ActiveCell.Address)


Function GetColorindex(ByVal r As String) As Long
Dim rngCurr As Range

    Set rngCurr = Selection
    Application.ScreenUpdating = False
    Range("IV1").Select
    
    Application.Dialogs(xlDialogPatterns).Show
    GetColorindex = ActiveCell.Interior.ColorIndex
    ActiveCell.Interior.ColorIndex = xlColorIndexAutomatic
    
    rngCurr.Select
    Set rngCurr = ActiveSheet.UsedRange
    Application.ScreenUpdating = True
    
End Function

      If Check1.Value =  1  Then
         .flags = .flags Or CC_RGBINIT
         .rgbResult = ??? 'сюда свой изначальный цвет подсовывавай
      End If