Данная функция позволяет запрашивать у пользователя цвет заливки.

Функция возвращает целое число - значение цвета в формате RGB

Пример использования:

Sub ОкраскаЯчейкиВВыбранныйЦвет()

On Error Resume Next

DefaultColor& = vbRed ' цвет по-умолчанию

NewColor& = PickNewColor(DefaultColor&) ' выбираем новый цвет

ActiveCell.Interior.Color = NewColor& ' красим активную ячейку

End Sub

Код функции:

Function PickNewColor(Optional ByVal i_OldColor As Double = xlNone) As Double

' функция отображает диалоговое окно выбора цвета заливки

' и возвращает значение выбранного цвета

On Error Resume Next:

PickNewColor = i_OldColor

Const BGColor As Long = 13160660, ColorIndexLast As Long = 32

Dim myOrgColor As Double, myNewColor As Double, WB As Workbook

Dim myRGB_R As Integer, myRGB_G As Integer, myRGB_B As Integer

If ActiveWorkbook Is Nothing Then Application.ScreenUpdating = False: Set WB = Workbooks.Add

myOrgColor = ActiveWorkbook.Colors(ColorIndexLast) 'save original palette color

i_Color = IIf(i_OldColor = xlNone, BGColor, i_OldColor): myRGB_R = i_Color Mod 256

i_Color = i_Color \ 256: myRGB_G = i_Color Mod 256

i_Color = i_Color \ 256: myRGB_B = i_Color Mod 256

ActiveWorkbook.ResetColors 'AppActivate Application.Name

If Application.Dialogs(xlDialogEditColor).Show(ColorIndexLast, myRGB_R, myRGB_G, myRGB_B) Then

PickNewColor = ActiveWorkbook.Colors(ColorIndexLast)

ThisWorkbook.Colors(ColorIndexLast) = myOrgColor

End If

If Not WB Is Nothing Then WB.Close False: Application.ScreenUpdating = True

End Function

В прикреплённом файле, - пример использования функции для выбора цветов на форме

• 6193 просмотра