29. Конвертер значений цветовых моделей. Конвертация значений RGB в HSL, RGB в Long, HSL в RGB, HSL в Long, Long в RGB и Long в HSL. Автоматическое вычисление значений RGB, HSL и Long при изменении цвета заливки ячейки.
Evgenyy, упустили Hex, Hex Excel и CMYK (редкий и непростой для конвертации HSL при этом не забыли)… Почему код сюда не выложили?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
В будущем можно будет и эти модели добавить в конвертер. Просто мне не приходилось использовать их в своей практике. Необходимо найти функции конвертирования, либо писать самому.
Цитата
написал: Почему код сюда не выложили?
Код и в модуле листа, и в модуле класса, и в обычном модуле. Всё настолько взаимосвязано, что по-моему проще скачать файл и посмотреть что, где и как расположено.
написал: HSL кстати есть в стандартной палитре Excel,
В стандартной палитре не верно отражаются значения модели, округленные до целочисленных значений. Например для чистых цветов L=127,5 , а показывает 128. Для конвертации из HSL в другие модели необходимо учитывать и десятые и сотые доли значения величин, а не только их целочисленные значения.
Evgenyy: Просто мне не приходилось использовать их в своей практике
цвета на UserForm задаются именно в Hex-Excel
Цитата
Evgenyy: Всё настолько взаимосвязано, что по-моему проще скачать файл
Думаю, что функции конвертации очень легко вынести в отдельный модуль
Вот мой (непричёсанный)
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub ФормаЦвет()
FRM_Color.Show
End Sub
'==================================================================================================
Sub frmColor_LongXLfromRange(rng As Range, Optional IfFont As Boolean)
Dim aR As Range
Dim arr(), r&, c&
For Each aR In rng.Areas
ReDim arr(aR.Rows.Count, aR.Columns.Count)
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
arr(r, c) = frmColor_LongXLfromCell(aR(r, c), IfFont)
Next r
Next c
aR.Value = arr
Next aR
End Sub
'--------------------------------------------------------------------------------------------------
Function frmColor_LongXLfromCell(cl As Range, Optional IfFont As Boolean)
If IfFont Then frmColor_LongXLfromCell = cl.DisplayFormat.Font.color: Exit Function
If cl.DisplayFormat.Interior.ColorIndex = xlNone Then frmColor_LongXLfromCell = vpWDash: Exit Function
frmColor_LongXLfromCell = cl.DisplayFormat.Interior.color
End Function
'==================================================================================================
'==================================================================================================
' «RGB-classic» <—> «RGB-long» in Excel
'==================================================================================================
Function frmColor_RGBtoLongXl(tmpArrRGB, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, i&, iLong&
iLong = RGB(tmpArrRGB(1), tmpArrRGB(2), tmpArrRGB(3))
If Not PRDX_CheckNum(iLong, 0, 0, 0, 0, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «RGB» (" & Join(tmpArrRGB, " | ") & ") успешно конвертирован в палитру «LongXl» (" & Join(iLong, " | ") & ")", vbInformation, "frmColor_RGBtoLongXl"
tmpArrRGB = iLong: frmColor_RGBtoLongXl = True
End Function
'==================================================================================================
Function frmColor_LongXlToRGB(tmpNum, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean ' проверки на Long-нет, кроме как попыткой преобразования
Dim arrRGB()
If Not PRDX_CheckNum(tmpNum, 0, 0, 0, 0, , MsgFalse) Then Exit Function
On Error Resume Next
arrRGB = Array(tmpNum Mod 256, tmpNum \ 256 Mod 256, tmpNum \ 65536 Mod 256)
On Error GoTo 0
If Not IsArray(arrRGB) Then GoTo ex
If MsgTrue Then MsgBox "Код из цветовой палитры «LongXl» (" & tmpNum & ") успешно конвертирован в палитру «RGB» (" & Join(arrRGB, " | ") & ")", vbInformation, "frmColor_LongXlToRGB"
tmpNum = arrRGB: frmColor_LongXlToRGB = True: Exit Function
ex: If MsgFalse Then MsgBox "Код из цветовой палитры «LongXl» (" & tmpNum & ") в цветовую палитру «RGB» конвертировать НЕ УДАЛОСЬ!", vbCritical, "frmColor_LongXlToRGB"
End Function
'==================================================================================================
'==================================================================================================
' «RGB» <—> «Hex»
'==================================================================================================
Function frmColor_RGBtoHex(tmpArrRGB, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim iHex$
iHex = "#" & Format$(Hex(tmpArrRGB(1)), "00") & Format$(Hex(tmpArrRGB(2)), "00") & Format$(Hex(tmpArrRGB(3)), "00")
If Not frmColor_CheckHex(iHex) Then If MsgFalse Then MsgBox "Код из цветовой палитры «RGB» (" & Join(tmpArrRGB, " | ") & ") корректно преобразовать в палитру «Hex» НЕ УДАЛОСЬ!", vbCritical, "frmColor_RGBtoHex": Exit Function Else Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «RGB» (" & Join(tmpArrRGB, " | ") & ") успешно конвертирован в палитру «Hex» (" & iHex & ")", vbInformation, "frmColor_RGBtoHex"
tmpArrRGB = iHex: frmColor_RGBtoHex = True
End Function
'==================================================================================================
Function frmColor_HexToRGB(tmpHex, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim arrRGB(3)
arrRGB(1) = --("&H" & Mid$(tmpHex, 2, 2)) ' AA из #AABBCC
arrRGB(2) = --("&H" & Mid$(tmpHex, 4, 2)) ' BB из #AABBCC
arrRGB(3) = --("&H" & Right$(tmpHex, 2)) ' CC из #AABBCC
If Not frmColor_CheckRGB(arrRGB, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «Hex» (" & tmpHex & ") успешно конвертирован в палитру «RGB» (" & Join(arrRGB, " | ") & ")", vbInformation, "frmColor_HexToRGB"
tmpHex = arrRGB: frmColor_HexToRGB = True
End Function
'==================================================================================================
' «Hex-classic» "#AABBCC" <—> «Hex-excel» "&H00CCBBAA&"
'==================================================================================================
Function frmColor_HexToHexXl(tmpHex, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim tx$
tx = "&H00" & Right$(tmpHex, 2) & Mid$(tmpHex, 4, 2) & Mid$(tmpHex, 2, 2) & "&"
If Not frmColor_CheckHexXl(tx, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «Hex» (" & tmpHex & ") успешно конвертирован в палитру «Hex-excel» (" & tx & ")", vbInformation, "frmColor_HexToHexXl"
tmpHex = tx: frmColor_HexToHexXl = True
End Function
'==================================================================================================
Function frmColor_HexXlToHex(tmpHexXl, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim iHex$
iHex = "#" & Mid$(tmpHexXl, 9, 2) & Mid$(tmpHexXl, 7, 2) & Mid$(tmpHexXl, 5, 2)
If Not frmColor_CheckHex(iHex, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «HexXL» (" & tmpHexXl & ") успешно конвертирован в палитру «Hex» (" & iHex & ")", vbInformation, "frmColor_HexXlToHex"
tmpHexXl = iHex: frmColor_HexXlToHex = True
End Function
'--------------------------------------------------------------------------------------------------
Function frmColor_HexXlToLongXL(tmpHexXl, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim iLong&
iLong = Val(tmpHexXl)
If MsgTrue Then MsgBox "Код из цветовой палитры «HexXL» (" & tmpHexXl & ") успешно конвертирован в палитру «LongXL» (" & iLong & ")", vbInformation, "frmColor_HexXlToLongXL"
tmpHexXl = iLong: frmColor_HexXlToLongXL = True
End Function
'==================================================================================================
' «RGB» <—> «CMYK»
'==================================================================================================
Function frmColor_RGBtoCMYK(tmpArrRGB, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim Rp#, Gp#, Bp#
Dim x, arrCMYK(4)
Rp = tmpArrRGB(1) / 255
Gp = tmpArrRGB(2) / 255
Bp = tmpArrRGB(3) / 255
x = Array(Rp, Gp, Bp)
If Not PRDX_Max(x, , MsgFalse) Then Exit Function
If x = 0 Then
arrCMYK(1) = 0: arrCMYK(2) = 0: arrCMYK(3) = 0: arrCMYK(4) = 1
Else
arrCMYK(1) = Round((x - Rp) / x, 2)
arrCMYK(2) = Round((x - Gp) / x, 2)
arrCMYK(3) = Round((x - Bp) / x, 2)
arrCMYK(4) = 1 - x
End If
If Not frmColor_CheckCMYK(arrCMYK, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «RGB» (" & Join(tmpArrRGB, " | ") & ") успешно конвертирован в палитру «CMYK» (" & Join(arrCMYK, " | ") & ")", vbInformation, "frmColor_RGBtoCMYK"
tmpArrRGB = arrCMYK: frmColor_RGBtoCMYK = True
End Function
'==================================================================================================
Function frmColor_CMYKtoRGB(tmpArrCMYK, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim arrRGB(3), s#, i&
s = 255 * (1 - tmpArrCMYK(3))
For i = 1 To UBound(arrRGB)
arrRGB(i) = Round(s * (1 - tmpArrCMYK(i)))
Next i
If Not frmColor_CheckRGB(arrRGB, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «CMYK» (" & Join(tmpArrCMYK, " | ") & ") успешно конвертирован в палитру «RGB» (" & Join(arrRGB, " | ") & ")", vbInformation, "frmColor_CMYKtoRGB"
tmpArrCMYK = arrRGB: frmColor_CMYKtoRGB = True
End Function
'--------------------------------------------------------------------------------------------------
Function frmColor_CMYKFormat(tmpArrCMYK, Optional Sep$, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim arrOld(), i&
If Not frmColor_CheckCMYK(tmpArrCMYK, , MsgFalse) Then Exit Function
arrOld = tmpArrCMYK
For i = 1 To UBound(tmpArrCMYK)
tmpArrCMYK(i) = Format$(tmpArrCMYK(i), "0%")
Next i
If Sep = "" Then
If MsgTrue Then MsgBox "Код из цветовой палитры «CMYK» (" & Join(arrOld, " | ") & ") успешно отформатирован по % «" & Join(tmpArrCMYK, " | ") & "»", vbInformation, "frmColor_CMYKformat"
Else
tmpArrCMYK = Join(tmpArrCMYK, Sep)
If MsgTrue Then MsgBox "Код из цветовой палитры «CMYK» (" & Join(arrOld, " | ") & ") успешно конвертирован в СТРОКУ «" & tmpArrCMYK & "»", vbInformation, "frmColor_CMYKformat"
End If
frmColor_CMYKFormat = True
End Function
'==================================================================================================
' «RGB» <—> «HSL» http://www.niwa.nu/2013/05/math-behind-colorspace-conversions-«RGB»-«HSL»/
'==================================================================================================
Function frmColor_RGBtoHSL(tmpArrRGB, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, y, iMin#, iMax#
Dim Rp#, Gp#, Bp#
Dim arrHSL(3), h#, s#, l#
Rp = tmpArrRGB(1) / 255
Gp = tmpArrRGB(2) / 255
Bp = tmpArrRGB(3) / 255
y = Array(Rp, Gp, Bp)
x = y: If Not PRDX_Min(x, , MsgFalse) Then Exit Function Else iMin = x
x = y: If Not PRDX_Max(x, , MsgFalse) Then Exit Function Else iMax = x
l = (iMin + iMax) / 2
If iMin = iMax Then
s = 0
ElseIf l < 0.5 Then
s = (iMax - iMin) / (iMax + iMin)
Else
s = (iMax - iMin) / (2 - iMax - iMin)
End If
If s = 0 Then
h = 0
ElseIf Rp >= Gp And Rp >= Bp Then
h = (Gp - Bp) / (iMax - iMin)
ElseIf Gp >= Rp And Gp >= Bp Then
h = 2 + (Bp - Rp) / (iMax - iMin)
Else
h = 4 + (Rp - Gp) / (iMax - iMin)
End If
h = h * 60
If h < 0 Then h = h + 360
arrHSL(1) = Round(h)
arrHSL(2) = Round(s, 2)
arrHSL(3) = Round(l, 2)
If Not frmColor_CheckHSL(arrHSL, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «RGB» (" & Join(tmpArrRGB, " | ") & ") успешно конвертирован в палитру «HSL» (" & Join(arrHSL, " | ") & ")", vbInformation, "frmColor_RGBtoHSL"
tmpArrRGB = arrHSL: frmColor_RGBtoHSL = True
End Function
'==================================================================================================
Function frmColor_HSLtoRGB(ByRef tmpArrHSL, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim h#, s#, l#
Dim iR#, iG#, iB#, tR#, tG#, tb#
Dim x, arrRGB(), k#, p#
h = Round(tmpArrHSL(1))
s = tmpArrHSL(2)
l = tmpArrHSL(3)
ReDim arrRGB(3)
If s = 0 Then
arrRGB(1) = Round(255 * l)
arrRGB(2) = Round(255 * l)
arrRGB(3) = Round(255 * l)
GoTo fin
End If
If l < 0.5 Then
k = l * (1 + s)
Else
k = l + s - l * s
End If
p = 2 * l - k
h = h / 360
tR = h + 0.333
tG = h
tb = h - 0.333
If tR < 0 Then tR = tR + 1
If tR > 1 Then tR = tR - 1
If tG < 0 Then tG = tG + 1
If tG > 1 Then tG = tG - 1
If tb < 0 Then tb = tb + 1
If tb > 1 Then tb = tb - 1
If 6 * tR < 1 Then
iR = p + (k - p) * 6 * tR
Else
If 2 * tR < 1 Then
iR = k
Else
If 3 * tR < 2 Then
iR = p + (k - p) * (0.666 - tR) * 6
Else
iR = p
End If
End If
End If
If 6 * tG < 1 Then
iG = p + (k - p) * 6 * tG
Else
If 2 * tG < 1 Then
iG = k
Else
If 3 * tG < 2 Then
iG = p + (k - p) * (0.666 - tG) * 6
Else
iG = p
End If
End If
End If
If 6 * tb < 1 Then
iB = p + (k - p) * 6 * tb
Else
If 2 * tb < 1 Then
iB = k
Else
If 3 * tb < 2 Then
iB = p + (k - p) * (0.666 - tb) * 6
Else
iB = p
End If
End If
End If
arrRGB(1) = Round(255 * iR)
arrRGB(2) = Round(255 * iG)
arrRGB(3) = Round(255 * iB)
If Not frmColor_CheckRGB(arrRGB, , MsgFalse) Then Exit Function
fin: tmpArrHSL = arrRGB: frmColor_HSLtoRGB = True
If MsgTrue Then MsgBox "Код из цветовой палитры «HSL» (" & Join(tmpArrHSL, " | ") & ") успешно конвертирован в палитру «RGB» (" & Join(arrRGB, " | ") & ")", vbInformation, "frmColor_HSLtoRGB"
End Function
'--------------------------------------------------------------------------------------------------
Function frmColor_HSLFormat(ByRef tmpArrHSL, Optional Sep$, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim arrOld(), tx$, i&
If Not frmColor_CheckHSL(tmpArrHSL, , MsgFalse) Then Exit Function
arrOld = tmpArrHSL
tmpArrHSL(1) = tmpArrHSL(1) & "°"
tmpArrHSL(2) = Format$(tmpArrHSL(2), "0%")
tmpArrHSL(3) = Format$(tmpArrHSL(3), "0%")
If Sep = "" Then
If MsgTrue Then MsgBox "Код из цветовой палитры «HSL» (" & Join(arrOld, " | ") & ") успешно отформатирован по % «" & Join(tmpArrHSL, " | ") & "»", vbInformation, "frmColor_HSLformat"
Else
tmpArrHSL = Join(tmpArrHSL, Sep)
If MsgTrue Then MsgBox "Код из цветовой палитры «HSL» (" & Join(arrOld, " | ") & ") успешно конвертирован в СТРОКУ «" & tmpArrHSL & "»", vbInformation, "frmColor_HSLformat"
End If
frmColor_HSLFormat = True
End Function
'==================================================================================================
' «HSL-classic» <—> «HSL-excel» in Excel palette (0-255 for each)
' Массив «HSLxl» после преобразования «HSLtoHSLxl» не пройдёт проверку, т.к. на выходе будет массив (0 To 2) [0-255] (long)
'==================================================================================================
Function frmColor_HSLtoHSLxl(ByRef tmpArrHSL, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, arrHSLxl(3)
arrHSLxl(1) = Round(tmpArrHSL(1) * 255 / 360)
arrHSLxl(2) = Round(tmpArrHSL(2) * 255)
arrHSLxl(3) = Round(tmpArrHSL(3) * 255)
If MsgTrue Then MsgBox "Код из цветовой палитры «HSL-classic» (" & Join(tmpArrHSL, " | ") & ") успешно конвертирован в палитру «HSL-excel» (" & Join(arrHSLxl, " | ") & ")", vbInformation, "frmColor_HSLtoHSLxl"
tmpArrHSL = arrHSLxl: frmColor_HSLtoHSLxl = True
End Function
'==================================================================================================
Function frmColor_HSLxlToHSL(ByRef tmpArrHSLxl, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, arrHSL(3)
arrHSL(1) = Round(tmpArrHSLxl(1) / 255 * 360)
arrHSL(2) = Round(tmpArrHSLxl(2) / 255, 2)
arrHSL(3) = Round(tmpArrHSLxl(3) / 255, 2)
If Not frmColor_CheckHSL(arrHSL, , MsgFalse) Then Exit Function
If MsgTrue Then MsgBox "Код из цветовой палитры «HSL-excel» (" & Join(tmpArrHSLxl, " | ") & ") успешно конвертирован в палитру «HSL-classic» (" & Join(arrHSL, " | ") & ")", vbInformation, "frmColor_HSLxlToHSL"
tmpArrHSLxl = arrHSL: frmColor_HSLxlToHSL = True
End Function
Вот проверки. Тоже не корректировал для форума. Чего-то может не быть для работы
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' https://exceloffthegrid.com/convert-color-codes/
' https://colorscheme.ru/color-converter.html
' «LongXL» (.Color)
' код цвета в виде числа, используемый в VBA для отображения информации по цвету
' вычисляется из «RGB» по формуле: R + 256*G + 256^2*B
' «RGB» (Red, Green, Blue)
' отдельные цвета красного, зелёного и синего имеют 256 (0-255) различных оттенков, которые при смешивании могут создать 16 777 216 различных цветовых комбинаций
' «Hex»: специальный 16-тиричный код цвета
' «HexXl» отличается не только префиксом и суффиксом, но и обратным порядком парных цифр/букв: «#AABBCC» = «&H00CCBBAA&»
' «CMYK» (0-1: концентрация до 100% для каждого элемента)
' • Cyan (голубой)
' • Magenta (пурпурный)
' • Yellow (жёлтый)
' • blacK (чёрный)
' «HSL»:
' • Hue (оттенок) – угол цветового колеса от (0-360), где 0 - красный, 120 - зелёный, а 240 - синий
' • Saturation (насыщенность 0-1) – % от количества включаемых цветов, где 100% является полноцветным, а 0% не является цветом (т.е. все серые)
' • Luminance or Lightness (яркость или освещённость 0-1)
' Excel не поддерживает «HSL» в классическом формате. Вместо этого для каждого из 3ёх параметров предусмотрена шкала 0-255, как для «RGB»
' !!! ПРЕДУСМОТРЕТЬ:
' … проверку в родительских процедурах на ПРОЗРАЧНУЮ заливку (ОТСУТСТВИЕ заливки): xlNone = vpClrNone = -4142 = 16777215
' … фактор отличия между «RGB» и «HSLxl». У них одинаковые параметры: 3 элемента с диапазоном [0-255](Long)
'
'==================================================================================================
'==================================================================================================
' Функция для проверки переданного значения/массива на соответствие любой из 5ти представленных цветовых палитр
' в случае успеха, возвращает название исходной цветовой палитры + преобразовывает первый аргумент в «RGB»-массив
'==================================================================================================
Function frmColor_NamePalette(ByRef tmpVl, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As String
Dim x, tx$, n&
x = tmpVl
If IsArray(tmpVl) Then ' RGB / HSL's / CMYK
n = PRDX_ArrType(tmpVl, MsgFalse, MsgFalse)
If n <> 11 Then Exit Function
If UBound(tmpVl) = 3 Then ' RGB or HSL
If frmColor_CheckRGB(x, MsgTrue) Then tx = "«RGB»": GoTo fin
x = tmpVl
If frmColor_CheckHSL(x) Then ' HSL
tx = "«HSL»"
If frmColor_HSLtoRGB(x, MsgTrue, MsgFalse) Then GoTo fin
Else
If MsgFalse Then MsgBox "Одномерный массив с 3мя элементами под цветовые палитры «RGB» и «HSL» НЕ ПОДХОДИТ!", vbCritical, "frmColor_NamePalette"
End If
ElseIf UBound(tmpVl) = 4 Then ' CMYK or HSLxl
If frmColor_CheckCMYK(x) Then
tx = "«CMYK»"
If frmColor_CMYKtoRGB(x, MsgTrue, MsgFalse) Then GoTo fin
Else
x = tmpVl
If frmColor_CheckHSLxl(x) Then ' HSLxl
tx = "«HSLxl»"
If Not frmColor_HSLxlToHSL(x, , MsgFalse) Then Exit Function
If frmColor_HSLtoRGB(x, MsgTrue, MsgFalse) Then GoTo fin
Else
If MsgFalse Then MsgBox "Одномерный массив с 4мя элементами под цветовые палитры «CMYK» и «HSLxl» НЕ ПОДХОДИТ!", vbCritical, "frmColor_NamePalette"
End If
End If
Else
If MsgFalse Then MsgBox "Количество элементов одномерного массива (" & UBound(tmpVl) + 1 & ") может равняться только 3ём или 4ём!", vbCritical, "frmColor_NamePalette"
End If
ElseIf IsNumeric(tmpVl) Then ' LongXl
If frmColor_LongXlToRGB(x, MsgTrue, MsgFalse) Then tx = "LongXl": GoTo fin
ElseIf TypeName(tmpVl) = "String" Then ' Hex's
If frmColor_CheckHex(x) Then ' Hex
tx = "«Hex»"
If frmColor_HexToRGB(x, MsgTrue, MsgFalse) Then GoTo fin
Else
x = tmpVl
If frmColor_CheckHexXl(x) Then
tx = "«HexXl»"
If Not frmColor_HexXlToHex(x, , MsgFalse) Then Exit Function
If frmColor_HexToRGB(x, MsgTrue, MsgFalse) Then GoTo fin
Else
If MsgFalse Then MsgBox "Строка «" & x & "» под цветовые палитры «Hex's» НЕ ПОДХОДИТ!", vbCritical, "frmColor_NamePalette"
End If
End If
Else
If MsgFalse Then MsgBox "Тип значения (" & TypeName(tmpVl) & ") ДОПУСТИМЫМ НЕ ЯВЛЯЕТСЯ!", vbCritical, "frmColor_NamePalette"
End If
Exit Function
fin: tmpVl = x
frmColor_NamePalette = tx
End Function
'==================================================================================================
' «Hex's» "#AABBCC" <—> "&H00CCBBAA&" (ONLY "&H00FFFFFF" Or "&HFFFFFF" Is NUMERIC)
'==================================================================================================
Function frmColor_CheckHex(v, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
If Not PRDX_IsString(v, , MsgFalse) Then Exit Function
If Len(v) <> 7 Or Left$(v, 1) <> "#" Or Not IsNumeric("&H" & Mid$(v, 2)) Then
If MsgFalse Then MsgBox "Строка «" & v & "» к цветовой палитре «Hex» НЕ ПРИНАДЛЕЖИТ!", vbCritical, "frmColor_CheckHex"
Exit Function
End If
frmColor_CheckHex = True
If MsgTrue Then MsgBox "Строка «" & v & "» принадлежит к цветовой палитре «Hex»!", vbInformation, "frmColor_CheckHex"
End Function
'--------------------------------------------------------------------------------------------------
Function frmColor_CheckHexXl(v, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
If Not PRDX_IsString(v, , MsgFalse) Then Exit Function
If Not UCase$(v) Like "&H00??????&" Or Not IsNumeric(Left$(v, Len(v) - 1)) Then
If MsgFalse Then MsgBox "Строка «" & v & "» к цветовой палитре «Hex-excel» НЕ ПРИНАДЛЕЖИТ!", vbCritical, "frmColor_CheckHexXl"
Exit Function
End If
frmColor_CheckHexXl = True
If MsgTrue Then MsgBox "Строка «" & v & "» принадлежит к цветовой палитре «Hex-excel»!", vbInformation, "frmColor_CheckHexXl"
End Function
'==================================================================================================
' «HSL» одномерный массив (3), с диапазонами элементов: [0-360](Long)/[0-1](%)/[0-1](%)
' «HSLxl» (добавлен фактор отличия от RGB) одномерный массив (4), где 3 элемента в диапазоне [0-255] (Целые числа, как у RGB) и 1 элемент строковый со значением «HSL»
' После проверки вернёт массив (3), с диапазонами элементов: [0-255](Long), как у RGB
'==================================================================================================
Function frmColor_CheckHSL(tmpArrHSL, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, n&
If Not PRDX_CheckCountLimits(tmpArrHSL, 3, 3, , MsgFalse) Then Exit Function
For Each x In tmpArrHSL
If Not IsNumeric(x) Then GoTo ex
If x < 0 Or x > 360 Then GoTo ex
Next x
If tmpArrHSL(1) <> Fix(tmpArrHSL(1)) Or tmpArrHSL(2) > 1 Or tmpArrHSL(3) > 1 Then GoTo ex
If MsgTrue Then MsgBox "Массив (" & Join(tmpArrHSL, " | ") & ") соответствует цветовой палитре «HSL»", vbInformation, "frmColor_CheckHSL"
frmColor_CheckHSL = True: Exit Function
ex: If MsgFalse Then MsgBox "Массив «" & Join(tmpArrHSL, " | ") & "» цветовой палитре «HSL» НЕ СООТВЕТСТВУЕТ!", vbInformation, "frmColor_CheckHSL"
End Function
'--------------------------------------------------------------------------------------------------
Function frmColor_CheckHSLxl(tmpArrHSLxl, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x(), i&, n&
If Not PRDX_CheckCountLimits(tmpArrHSLxl, 4, 4, , MsgFalse) Then Exit Function
ReDim x(4)
For i = 1 To 4
If IsNumeric(tmpArrHSLxl(i)) Then
n = n + 1: If n > 2 Then GoTo ex
x(n) = --tmpArrHSLxl(i): If x(n) < 0 Or x(n) > 255 Or x(n) <> Fix(x(n)) Then GoTo ex
Else
If LCase$(tmpArrHSLxl(i)) <> "hsl" Then GoTo ex
End If
Next i
If n <> 3 Then GoTo ex Else tmpArrHSLxl = x
If MsgTrue Then MsgBox "Массив (" & Join(tmpArrHSLxl, " | ") & ") соответствует цветовой палитре «HSLxl»", vbInformation, "frmColor_CheckHSLxl"
frmColor_CheckHSLxl = True: Exit Function
ex: If MsgFalse Then MsgBox "Массив «" & Join(tmpArrHSLxl, " | ") & "» цветовой палитре «HSLxl» НЕ СООТВЕТСТВУЕТ!", vbInformation, "frmColor_CheckHSLxl"
End Function
'==================================================================================================
' «CMYK» одномерный массив (4), где каждый элемент в диапазоне [0-1] (Десятичные числа - %)
'==================================================================================================
Function frmColor_CheckCMYK(ByRef tmpArrCMYK, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, n&
If Not PRDX_CheckCountLimits(tmpArrCMYK, 4, 4, , MsgFalse) Then Exit Function
For Each x In tmpArrCMYK
If Not IsNumeric(x) Then GoTo ex
If x < 0 Or x > 1 Then GoTo ex
Next x
If MsgTrue Then MsgBox "Массив (" & Join(tmpArrCMYK, " | ") & ") соответствует цветовой палитре «CMYK»", vbInformation, "frmColor_CheckCMYK"
frmColor_CheckCMYK = True: Exit Function
ex: If MsgFalse Then MsgBox "Массив «" & Join(tmpArrCMYK, " | ") & "» цветовой палитре «CMYK» НЕ СООТВЕТСТВУЕТ!", vbInformation, "frmColor_CheckCMYK"
End Function
'==================================================================================================
' «RGB» одномерный массив (0 To 2), где каждый элемент в диапазоне [0-255] (Целые числа)
'==================================================================================================
Function frmColor_CheckRGB(tmpArrRGB, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, n&
If Not PRDX_CheckCountLimits(tmpArrRGB, 3, 3, , MsgFalse) Then Exit Function
For Each x In tmpArrRGB
If Not IsNumeric(x) Then GoTo ex
If x < 0 Or x > 255 Or x <> Fix(x) Then GoTo ex
Next x
If MsgTrue Then MsgBox "Массив (" & Join(tmpArrRGB, " | ") & ") соответствует цветовой палитре «RGB»", vbInformation, "frmColor_CheckRGB"
frmColor_CheckRGB = True: Exit Function
ex: If MsgFalse Then MsgBox "Массив «" & Join(tmpArrRGB, " | ") & "» цветовой палитре «RGB» НЕ СООТВЕТСТВУЕТ!", vbInformation, "frmColor_CheckRGB"
End Function
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Evgenyy: Это известно конечно, но обычно используешь уже предустановленные цвета
интересно, а по этой логике, зачем вам HSL?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
весьма спорное утверждение. Каждая палитра нужна для чего-то и говорить "вот эта лучше всех" — очень глупо… Да, в примере использования базового цвета и получения его "производных" оттенков — HSL подходит отлично (или даже - лучше всех), согласен. Но данными примерами операции с цветами не ограничиваются, и громкость заголовка говорит только о том, что автор просто не разбирается в вопросе полностью. Например, обходится стороной вопрос получения этого самого "базового" цвета…
Я вас спросил, для чего вам HSL в Excel, ведь он вы чистом виде нигде не указывается, в отличие от RGB и HEX (оба нестандартные).
Моя форма, например, выводит ВСЕ популярные палитры
а почему нужно игнорировать Hex, который есть, но при этом брать HSL, которого нет - непонятно…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
написал: автор просто не разбирается в вопросе полностью
Автор же не я, а статья просто приведена в качестве примера о преимуществах модели HSL. Никто не игнорирует другие модели. Если они созданы, значит они нужны в большей или меньшей степени для каждого индивидуально.
Цитата
написал: для чего вам HSL в Excel
Модель HSL наилучшим образом приближена к восприятию человеком цвета. Глядя на значения величин HSL можно представить и понять какой это цвет, чего не скажешь о других цветовых моделях. Попробуйте навскидку определить цвет по значениям RGB или HEX или Long. У вас это не получится, а по значениям HSL можно приблизительно представить какой тон цвета, насколько он насыщенный, светлый или темный (или чистый цвет). Да, в чистом виде HSL пока нигде не указывается, но, например, используется в алгоритме смешения цветов.
Что касается формы, то значения в ней во второй строке уже неверные. Об этом я писал выше. А если значения неверные, то грош - цена такой формы.
Evgenyy: Что касается формы, то значения в ней во второй строке уже неверные. Об этом я писал выше. А если значения неверные, то грош - цена такой формы.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Всё очень просто. Подставьте значения RGB (255, 255, 0) для желтого цвета в мой конвертер, и вы увидите какими должны быть значения HSL (42.5, 255, 127.5). Значениям HSL (42, 255, 128), указанным в вашей форме, соответствуют значения RGB (255, 251, 1), а это уже другой цвет, хотя тоже желтый, но другой желтый. Вот и доказательство того, что форма не совершенна.
Sub t()
Dim a()
a = Array(255, 255, 0)
frmColor_RGBtoHSL a: Debug.Print a(1), a(2), a(3) ' 60 1 0,5
frmColor_HSLtoRGB a: Debug.Print a(1), a(2), a(3) ' 255 255 0
End Sub
Алгоритм перегоняет всё правильно, но я посчитал, что для HSL Excel точности хватает до целых. При обратной перегонке, возможны нестыковки, но я на это не рассчитывал. Человеческий глаз (и любой продавец краски), разумеется, со мной полностью согласен и ошибок нет - только осмысленная точность
Сделать вычисления более точными поможет редактирование округления в таких строках
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
30. Окрашивание символов текста. Все символы разделены на 6 групп: русский алфавит, английский алфавит, цифры, знаки препинания, математические знаки и прочие символы. При изменении цвета шрифта какой-либо группы в таблице «Выбор цвета шрифта», автоматически окрашиваются символы во всех ячейках на активном листе в соответствии с выбранными цветами. Также автоматически окрашиваются символы в ячейке, при изменении значения этой ячейки, в цвета, установленные в таблице «Выбор цвета шрифта".
Ещё больше различных функций в сборнике пользовательских функций на Яндекс.Диске: Library_UDF
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Я вас спросил, для чего вам HSL в Excel
Для выбора цвета наиболее интуитивно понятными компонентами цветовой модели HSL.
31. Форма для выбора цвета компонентами HSL. Немодальная форма для выбора цвета заливки ячеек и цвета шрифта. Выбирайте ячейки, на форме настраивайте необходимые цвета. Для заливки выбранными цветами используйте кнопку "Применить".
32. Форма "Цветовая палитра". Немодальная форма для выбора цвета заливки ячеек. На форме настраивается палитра скроллбарами: количество оттенков палитры (3 - 24), начальное значение оттенка в палитре (0 - 254), начальное (130 - 240) и конечное (20 - 120) значения светлоты для оттенков. Окрашивание выделенных ячеек по клику на кнопку с выбранным цветом.
33. Форма "Цветная клавиатура". Немодальная форма - экранная клавиатура с изменяемым цветом кнопок. Изменение цвета кнопок происходит при наведении курсора мыши на кнопки клавиатуры. Различные группы кнопок окрашиваются разными цветами.
А в Outlook (HTML) какая цветовая схема использована? Помню перегонял RGB, точнее переставлял крайние байты местами в коде цвета при конвертации из экселя в HTML.
При конвертации с Excel в HTML (в аутлук можно в качестве тела письма что-то добавить только в этом формате) цвет передаваемый в RGB инвертируется по старшему и младшему байтам (R<>B). Вот и интересно какая там цветовая схема или стандарт используется.
34. Обмен функционала кнопок выбора цвета на ленте. Кнопкой "Цвет заливки" на ленте выбираем цвет текста, а кнопкой "Цвет текста" - выбираем цвет заливки ячейки.
Evgenyy: Кнопкой "Цвет заливки" на ленте выбираем цвет текста, а кнопкой "Цвет текста" - выбираем цвет заливки ячейки.
у данной программы есть практическое применение или просто? Я вот абсолютно не понимаю, зачем может быть нужно менять местами функционал — это же только запутает пользователей… Я бы ещё понял кнопки местами поменять (мало ли кому и как удобнее), но функционал …
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Evgenyy: Это ж эксперименты. Просто показаны возможности Excel.
понял — вопросов больше не имею
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄