|
Данная функция позволяет запрашивать у пользователя цвет заливки.
Функция возвращает целое число - значение цвета в формате 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
В прикреплённом файле, - пример использования функции для выбора цветов на форме
|
