VBAでRGB２HSV変換。

ネットで拾ったソースコードをエクセル2016で使えるように改修したもの。
このおもちゃに一時間かかったと思うとかけすぎである。
まぁ　試してもらえれば効果は分かる。あと明度や彩度まで回転式になってるので、
嫌な人はSとVの値を０〜１００になるようにクリップするなりコンプ作るなりしてくれろ。
とりあえず以下ソース。モジュールは分けてもらわないとテスト関数が暴発するはず。

’まず計算用モジュール。

Function Bigger(ByVal A As Single, B As Single)

Max = A

If A < B Then

    Max = B

Else

End If

Bigger = Max

End Function

Function Smaller(ByVal A As Single, B As Single)

Dim min

min = A

If A > B Then

        min = B

Else

End If

Smaller = min

End Function

Sub test()

    Dim Data(4) As Variant

'    Data(0) = 0

'    Data(1) = 1

    Data(2) = 2

'    Data(3) = 3

    Data(4) = 4

    

'    MsgBox "Max:" & Maximam(Data) & " ,Min:" & Minimam(Data)

    MsgBox "Max:" & Data(Biggest(Data)) & " ,Min:" & Data(Smallest(Data))

End Sub

Function Biggest(ByVal InData)

'最大値の入っていた配列番号を返す

    Dim crntmax

    Dim n

    For n = 0 To UBound(InData)

        If InData(n) = "" Then

            

        Else

            Exit For

        End If

    Next

    crntmin = InData(LBound(InData) + n)

    For i = LBound(InData) + n To UBound(InData)

        If UBound(InData) - LBound(InData) = i Then

            Exit For

        End If

        If InData(i) < InData(i + 1) Then

'            crntmax = InData(i + 1)

            crntmax = i + 1

        End If

    Next

    Biggest = crntmax

End Function

Function Smallest(ByVal InData)

'空白以外の最小値の配列番号を返す

    Dim crntmin

    Dim n

    For n = 0 To UBound(InData)

        If InData(n) = "" Then

            

        Else

            Exit For

        End If

    Next

    crntmin = InData(LBound(InData) + n)

    For i = LBound(InData) + n To UBound(InData)

        If UBound(InData) - LBound(InData) = i Then

            Exit For

        End If

        If InData(i + 1) = "" Then

        

        ElseIf InData(i) > InData(i + 1) Then

'            crntmin = InData(i + 1)

            crntmin = i + 1

        End If

    Next

    Smallest = crntmin

End Function

’次に色変換系

Sub TestColor()

    Dim BaseColor As Long

    Dim RGBData As Long

    Dim H As Single, S As Single, V As Single

    Dim Rad As Long

    Dim Sat As Long

    Dim Val As Long

    Dim rgb

    Rad = 12

    Val = -10

    Sat = 10

    BaseColor = ThisWorkbook.ActiveSheet.Range("B3").Interior.Color

    

    For i = 1 To 30

        ThisWorkbook.ActiveSheet.Range("B3").Offset(i, 0).Interior.Color = ChgColorHue(BaseColor, Rad * i)

        ThisWorkbook.ActiveSheet.Range("A3").Offset(i, 0).Interior.Color = MonoTone(ThisWorkbook.ActiveSheet.Range("B3").Offset(i, 0).Interior.Color)

    Next

    ThisWorkbook.ActiveSheet.Range("C3").Interior.Color = ChgColorVal(BaseColor, Val)

    ThisWorkbook.ActiveSheet.Range("C4").Interior.Color = ChgColorSat(BaseColor, Sat)

End Sub

Sub testrgbVal()

    Dim rgb As Variant

    rgb = RevRGB(ThisWorkbook.ActiveSheet.Range("B3").Interior.Color)

    MsgBox "RGB(" & rgb(1) & "," & rgb(2) & "," & rgb(3) & ")"

End Sub

Function RevRGB(Color As Long) As Variant

'RGBを配列で返す

Dim c, rgb(3) As Variant

c = Right("000000" & Hex(Color), 6)

rgb(1) = Val("&H" & Right(c, 2))

rgb(2) = Val("&H" & Mid(c, 3, 2))

rgb(3) = Val("&H" & Left(c, 2))

RevRGB = rgb

'MsgBox "RGB(" & r & "," & g & "," & B & ")"

End Function

Function MonoTone(ByVal Color) As Long

    Dim RGBData As Long

    Dim H As Single, S As Single, V As Single

    

    Call RGB_ToHSV(Color, H, S, V)

'    H = 0

    S = 0

    Call RGB_FromHSV(RGBData, H, S, V)

    MonoTone = RGBData

End Function

Function ChgColorHue(ByVal Color As Long, Rad As Long) As Long

    Dim RGBData As Long

    Dim H As Single, S As Single, V As Single

    

    Call RGB_ToHSV(Color, H, S, V)

    H = (H + Rad) Mod 360

    Call RGB_FromHSV(RGBData, H, S, V)

    ChgColorHue = RGBData

End Function

Function ChgColorSat(ByVal Color As Long, Sat As Long) As Long

    Dim RGBData As Long

    Dim H As Single, S As Single, V As Single

    

    Call RGB_ToHSV(Color, H, S, V)

    S = (S + Sat) Mod 100

    Call RGB_FromHSV(RGBData, H, S, V)

    ChgColorSat = RGBData

End Function

Function ChgColorVal(ByVal Color As Long, Val As Long) As Long

    Dim RGBData As Long

    Dim H As Single, S As Single, V As Single

    

    Call RGB_ToHSV(Color, H, S, V)

    V = (V + Val) Mod 100

    Call RGB_FromHSV(RGBData, H, S, V)

    ChgColorVal = RGBData

End Function

Sub RGB_ToHSV(ByVal iiRGB As Long, ByRef orH As Single, ByRef orS As Single, ByRef orV As Single)

    Dim rR As Single, rG As Single, rB As Single

    Dim rKr As Single, rKg As Single, rKb As Single

    Dim rMin As Single, rDiff As Single

    Dim c As String

    rMin = 1

    orV = 0

    '' ３原色を分離して百分率に。

    c = Right("000000" & Hex(iiRGB), 6)

    rR = Val("&H" & Right(c, 2))

    rR = rR / 255

    rG = Val("&H" & Mid(c, 3, 2))

    rG = rG / 255

    rB = Val("&H" & Left(c, 2))

    rB = rB / 255

    

    '' 明度は、RGB 各要素の最大のものと同等です。

    orV = Bigger(rG, rB)

    orV = Bigger(rR, orV)

    '' 彩度は、RGB 各要素の最小と最大の差を、最大で割ったもの。

    rMin = Smaller(rG, rB)

    rMin = Smaller(rR, rMin)

    rDiff = orV - rMin

    If orV <> 0 Then

        orS = (rDiff / orV)

    Else

        orS = 0

    End If

    '' 色相は、どの値が最大値だったかにより違い、以下の計算で求まります。

    '' 　最大の値により、色相角が決まるのです。

    '' 　またここで、0 =< and < 360 の範囲に収めます。

    '' 　ただし、色がなければ、色相はゼロです。

    If orS = 0 Then

        orH = 0

    Else

        rKr = (orV - rR) / rDiff

        rKg = (orV - rG) / rDiff

        rKb = (orV - rB) / rDiff

        Select Case orV

            Case rR: orH = rKb - rKg

            Case rG: orH = 2 + rKr - rKb

            Case rB: orH = 4 + rKg - rKr

        End Select

        orH = orH * 60: If orH < 0 Then orH = orH + 360

    End If

    '' 明度・彩度を 0 ～ 100 にします。

    orV = orV * 100

    orS = orS * 100

End Sub

Sub RGB_FromHSV(ByRef oiRGB As Long, ByVal irH As Single, ByVal irS As Single, ByVal irV As Single)

    Dim rR As Single, rG As Single, rB As Single

    Dim iI As Integer

    Dim rF As Single, rP As Single, rQ As Single, rT As Single

        

    '' 数値を 1 以下に収めます。

    irS = irS / 100

    irV = irV / 100

    

    If irS = 0 Then

        rR = irV

        rG = irV

        rB = irV

    Else

        irH = irH / 60

        If irH = 6 Then irH = 0

        iI = Int(irH)

        rF = irH - iI

        rP = irV * (1 - irS)

        rQ = irV * (1 - irS * rF)

        rT = irV * (1 - (irS * (1 - rF)))

        Select Case iI

            Case 0: rR = irV:   rG = rT:    rB = rP

            Case 1: rR = rQ:    rG = irV:   rB = rP

            Case 2: rR = rP:    rG = irV:   rB = rT

            Case 3: rR = rP:    rG = rQ:    rB = irV

            Case 4: rR = rT:    rG = rP:    rB = irV

            Case 5: rR = irV:   rG = rP:    rB = rQ

        End Select

    End If

    oiRGB = rgb(Int(rR * 255.9999), Int(rG * 255.9999), Int(rB * 255.9999))

End Sub

’で、飾りで表示行検索

Function NextVisibleRow(ByVal CrntRow As Range, UorL) As Range

    If UorL = U Then

        For NofR = 1 To 1000

        If CrntRow.Offset(-NofR, 0).EntireRow.Hidden = False Then

            Exit For

        End If

        Next

        Set NextVisibleRow = CrntRow.Offset(-NofR, 0)

    Else

        For NofR = 1 To 10000

        If CrntRow.Offset(NofR, 0).EntireRow.Hidden = False Then

            Exit For

        End If

        Next

        Set NextVisibleRow = CrntRow.Offset(NofR, 0)

    End If

End Function

Function NextVisibleCol(ByVal CrntCol As Range, LorR) As Range

    If LorR = L Then

        For NofC = 1 To 1000

        If CrntCol.Offset(-NofC, 0).EntireColumn.Hidden = False Then

            Exit For

        End If

        Next

        Set NextVisibleCol = CrntCol.Offset(-NofC, 0)

    Else

        For NofC = 1 To 1000

        If CrntCol.Offset(NofC, 0).EntireColumn.Hidden = False Then

            Exit For

        End If

        Next

        Set NextVisibleCol = CrntCol.Offset(NofC, 0)

    End If

End Function

Sub test()

    Dim tgtrow As Range

    Set tgtrow = NextVisibleRow(Range("A9"), U)

    MsgBox tgtrow.Address

End Sub