Powerpoint Macro to fill shapes with a gradient

gradient.vba

Option Explicit

Public Function Max(x, y As Variant) As Variant
  Max = IIf(x > y, x, y)
End Function

Public Function Min(x, y As Variant) As Variant
   Min = IIf(x < y, x, y)
End Function

Function GetR(ByVal x As Long) As Integer
    GetR = (x Mod 256)
End Function

Function GetG(ByVal x As Long) As Integer
    GetG = (x \ 256) Mod 256
End Function

Function GetB(ByVal x As Long) As Integer
    GetB = (x \ 65536) Mod 256
End Function

Function GetHSLFromRGB(ByVal Red As Integer, ByVal Green As Integer, ByVal Blue As Integer, HSL As String)

Dim RedPct As Double
Dim GreenPct As Double
Dim BluePct As Double
Dim MinRGB As Double
Dim MaxRGB As Double
Dim H As Double
Dim S As Double
Dim L As Double

RedPct = Red / 255
GreenPct = Green / 255
BluePct = Blue / 255

MinRGB = Min(RedPct, Min(GreenPct, BluePct))
MaxRGB = Max(RedPct, Max(GreenPct, BluePct))

L = (MinRGB + MaxRGB) / 2

If MinRGB = MaxRGB Then
    S = 0
ElseIf L < 0.5 Then
    S = (MaxRGB - MinRGB) / (MaxRGB + MinRGB)
Else
    S = (MaxRGB - MinRGB) / (2 - MaxRGB - MinRGB)
End If

If S = 0 Then
    H = 0
ElseIf RedPct >= Max(GreenPct, BluePct) Then
    H = (GreenPct - BluePct) / (MaxRGB - MinRGB)
ElseIf GreenPct >= Max(RedPct, BluePct) Then
    H = 2 + (BluePct - RedPct) / (MaxRGB - MinRGB)
Else
    H = 4 + (RedPct - GreenPct) / (MaxRGB - MinRGB)
End If

H = H * 60

If H < 0 Then H = H + 360

Select Case HSL

    Case "H"
        GetHSLFromRGB = H

    Case "S"
        GetHSLFromRGB = S

    Case "L"
        GetHSLFromRGB = L

End Select

End Function

Function GetRGBFromHSL(ByVal Hue As Double, ByVal Saturation As Double, ByVal Luminance As Double, RGB As String)

Dim r As Double
Dim g As Double
Dim b As Double
Dim temp1 As Double
Dim temp2 As Double
Dim tempR As Double
Dim tempG As Double
Dim tempB As Double

If Saturation = 0 Then

    r = Luminance * 255
    g = Luminance * 255
    b = Luminance * 255

GoTo ReturnValue

End If

If Luminance < 0.5 Then
    temp1 = Luminance * (1 + Saturation)
Else
    temp1 = Luminance + Saturation - Luminance * Saturation
End If

temp2 = 2 * Luminance - temp1

Hue = Hue / 360

tempR = Hue + 0.333
tempG = Hue
tempB = Hue - 0.333

If tempR < 0 Then tempR = tempR + 1
If tempR > 1 Then tempR = tempR - 1
If tempG < 0 Then tempG = tempG + 1
If tempG > 1 Then tempG = tempG - 1
If tempB < 0 Then tempB = tempB + 1
If tempB > 1 Then tempB = tempB - 1

If 6 * tempR < 1 Then
    r = temp2 + (temp1 - temp2) * 6 * tempR
Else
    If 2 * tempR < 1 Then
        r = temp1
    Else
        If 3 * tempR < 2 Then
            r = temp2 + (temp1 - temp2) * (0.666 - tempR) * 6
        Else
            r = temp2
        End If
    End If
End If

If 6 * tempG < 1 Then
    g = temp2 + (temp1 - temp2) * 6 * tempG
Else
    If 2 * tempG < 1 Then
        g = temp1
    Else
        If 3 * tempG < 2 Then
            g = temp2 + (temp1 - temp2) * (0.666 - tempG) * 6
        Else
            g = temp2
        End If
    End If
End If

If 6 * tempB < 1 Then
    b = temp2 + (temp1 - temp2) * 6 * tempB
Else
    If 2 * tempB < 1 Then
        b = temp1
    Else
        If 3 * tempB < 2 Then
            b = temp2 + (temp1 - temp2) * (0.666 - tempB) * 6
        Else
            b = temp2
        End If
    End If
End If

r = r * 255
g = g * 255
b = b * 255

ReturnValue:
Select Case RGB

    Case "R"
        GetRGBFromHSL = Round(r, 0)

    Case "G"
        GetRGBFromHSL = Round(g, 0)

    Case "B"
        GetRGBFromHSL = Round(b, 0)

End Select

End Function

Sub FillGradient()

    Dim selection As ShapeRange
    Set selection = ActiveWindow.selection.ShapeRange
    
    Dim count As Integer
    count = selection.count
    
    Dim gradStart As Long
    gradStart = selection.Item(1).Fill.ForeColor.RGB
    
    Dim gradStartH As Double
    Dim gradStartS As Double
    Dim gradStartL As Double
    
    gradStartH = GetHSLFromRGB(GetR(gradStart), GetG(gradStart), GetB(gradStart), "H")
    gradStartS = GetHSLFromRGB(GetR(gradStart), GetG(gradStart), GetB(gradStart), "S")
    gradStartL = GetHSLFromRGB(GetR(gradStart), GetG(gradStart), GetB(gradStart), "L")
        
    Dim gradEnd As Long
    gradEnd = selection.Item(count).Fill.ForeColor.RGB
    
    Dim gradEndH As Double
    Dim gradEndS As Double
    Dim gradEndL As Double
    
    gradEndH = GetHSLFromRGB(GetR(gradEnd), GetG(gradEnd), GetB(gradEnd), "H")
    gradEndS = GetHSLFromRGB(GetR(gradEnd), GetG(gradEnd), GetB(gradEnd), "S")
    gradEndL = GetHSLFromRGB(GetR(gradEnd), GetG(gradEnd), GetB(gradEnd), "L")
        
    Dim index As Integer
    For index = 1 To count
        Dim shape As shape
        Set shape = selection.Item(index)
        
        Dim shapeH As Double
        Dim shapeS As Double
        Dim shapeL As Double
        
        shapeH = gradStartH + (index - 1) / (count - 1) * (gradEndH - gradStartH)
        shapeS = gradStartS + (index - 1) / (count - 1) * (gradEndS - gradStartS)
        shapeL = gradStartL + (index - 1) / (count - 1) * (gradEndL - gradStartL)
        
        Dim shapeR As Double
        Dim shapeG As Double
        Dim shapeB As Double
        
        shapeR = GetRGBFromHSL(shapeH, shapeS, shapeL, "R")
        shapeG = GetRGBFromHSL(shapeH, shapeS, shapeL, "G")
        shapeB = GetRGBFromHSL(shapeH, shapeS, shapeL, "B")
        
        shape.Fill.ForeColor.RGB = RGB(shapeR, shapeG, shapeB)
        
    Next index

End Sub