Attribute VB_Name = "fader"
 Const debugmode = 1
'Lord Orwell's fader .bas version 1.0
'function descriptions:
'ByteToHex:  converts a byte in the range of 0-255
'           to a two digit hex value string.
'CombineVBColor:  Swaps some numbers around to make the vb RGB function
'            work with vb colors, making a programming error less likely.
'CombineWebColor:  No real new functionality, but makes code easier to
'            understand.  Give it a red, green and blue(all 0-255) and it
'            will give you back the newly-combined color, which to use in
'            any useful manner will probably need to be converted to hex.
'ComputeComponentGradient: Computes the current red, green, or blue value
'            in a fade, given the following: start color, end color, total
'            steps, and current step.  Range for start and end are 0-255.
'ComputeFadedVBColor:  a fader in a sub!  Give it starting vb color, ending
'            vb color, total fade steps, and the current step you are on,
'            and it will do the rest (with the help of other subs)
'ComputeFadedWebColor: a fader in a sub!  Give it starting web color, ending
'            web color, total fade steps, and the current step you are on,
'            and it will do the rest (with the help of other subs)
'Errorcatch:  Called whenever a sub detects an
'             error in a value passed to it.
'Hextobyte:  Converts a one or two byte hex string into
'            a byte value in the range of 0-255.
'HexToLong:  Converts a hex string in the range of &H0 to &HFFFFFF to a long value.
'            works with web values or vb values.
'LongToHex:  Converts a long value into a 3 digit hex code.  Works for vb
'            color codes and long value web color codes.

'Splitvbcolor: takes a long vb color value for text color, etc.,
'              and returns the red, green, and blue values for it.
'Splitwebcolor: takes a long color value in rgb format and returns
'               the component values for it.
'SplitVBHextoRGB: Give it a 6 byte hex VB color value in a string.  It returns 3 integers in the
'                 range of 0-255 representing the blue, green, and red parts of the color.
'SplitVBHexToRGBHex: Takes a 6 digit hex vb color value and returns 3 2-digit hex strings.  One for
'                    blue, one for green, and one for the red portion of the color.
'SplitWebHexToRGB:  Takes a 6 digit hex string value and returns 3 integers in the range of 0-255.
'                   One for red, one for green, and one for the blue portion of the color.
'SplitWebHexToRGBHex:  Takes 6 digit hex color string in web form and returns 3 two-digit hex
'                      strings.  One each for the red, green, and blue components.
'validhex:  determines if a string contains characters
'          other than one or more of these: 0123456789abcdef
'          It't not case-sensitive.
'zeropad:  pass it a hex value as a string and
'          it will pad it with zeros to make it
'          6 digits.  Smallest zero-padder.  Learn from it.


Function ZeroPad(HexNumber As String) As String
If debugmode = 1 Then
   HexNumber = SpaceTrim(HexNumber)
   If ValidHex(HexNumber) = False Then Call Errorcatch(2, "Zeropad"): Exit Function
End If
If Len(HexNumber) > 6 Then Call Errorcatch(1, "Zeropad"): Exit Function
ZeroPad = Left$("000000", 6 - Len(HexNumber)) + HexNumber
End Function
Sub Errorcatch(num As Long, routine As String)
Dim ErrMsg As String
  If num = 1 Then ErrMsg = "Invalid length of string input into subroutine"
  If num = 2 Then ErrMsg = "Invalid character in string"
  MsgBox routine & ErrMsg, vbOKOnly
End Sub
Function ValidHex(HexNumber As String) As Boolean
'i make sure a string only contains these chars: 0123456789abcdef
   ValidHex = True
   Dim Char As String
   For Count = 1 To Len(HexNumber)
      Char = Mid$(HexNumber, Count, 1)
      If Val("&H" + Char) = 0 And Char <> "0" Then ValidHex = False
   Next Count
   
End Function
Function SpaceTrim(Text As String) As String
   If Text$ = "" Then Exit Function
   SpaceTrim$ = LTrim$(RTrim$(Text))
End Function
Function HexToByte(Text As String) As Byte
'pass me a hex value FF or lower, and i'll return an long
If debugmode = 1 Then
  Text = SpaceTrim(Text)
  If Len(Text) > 2 Then Call Errorcatch(1, "HexToByte"): Exit Function
  If ValidHex(Text) = False Then Call Errorcatch(2, "HexToByte"): Exit Function
End If
  HexToByte = Val("&H" + Text$)
End Function
Function ByteToHex(num As Byte) As String
If debugmode = 1 And num > 255 Then Call Errorcatch(1, "inttohex"): Exit Function
'this sub is here simply to help debugging
IntToHex = LTrim$(Hex$(num))
If Len(ByteToHex) < 2 Then ByteToHex = "0" + ByteToHex
End Function
Function LongToHex(num As Long) As String
Dim HexNum As String
HexNum = ZeroPad(Hex$(num))
LongToHex = HexNum
End Function
Function HexToLong(HexNum As String) As Long
If debugmode = 1 Then
  If ValidHex(HexNum) = False Then Call Errorcatch(2, "Hextolong"): Exit Function
  If Len(HexNum) = 0 Then Call Errorcatch(1, "Hextolong"): Exit Function
End If
HexToLong = Val("&H" + HexNum)
End Function

Sub SplitVBColor(VBColor As Long, Blue As Byte, Green As Byte, Red As Byte)
   'note to self:  AND is done after division.  Don't forget the ()!!!!
   If debugmode = 1 Then If VBColor < 0 Then MsgBox ("color less than zero!"): End
   Red = VBColor And &HFF
   Green = (VBColor And &HFF00&) \ &H100&
   Blue = (VBColor And &HFF0000) \ &H10000
End Sub
Sub SplitWebColor(WebColor As Long, Red As Byte, Green As Byte, Blue As Byte)
   'useful for faders
   Call SplitVBColor(WebColor, Red, Green, Blue)
End Sub
Function ComputeComponentGradient(Starting As Byte, Ending As Byte, TotalSteps As Integer, CurrentStep As Integer) As Byte
'to use this for smooth fading, keep in mind that the first step is the starting color.
' Step 2 is the first change.  keep this in mind when doing multiple-color fades in a row.
'When fading from a finished color to the next color, start the new color on step 2.
Dim GradientShift As Double
Dim NewValue As Long
Dim Range As Long
Range = (CLng(Ending) - CLng(Starting))
If Range < 0 Then Range = Range - 1 Else Range = Range + 1
If debugmode = 1 Then
   If TotalSteps < CurrentStep Or TotalSteps < 1 Or CurrentStep < 1 Then Call Errorcatch(1, "CompuTeFaDegraDient"): Exit Function
End If
  GradientShift = Range / (TotalSteps)
  NewValue = Starting + Int((GradientShift * CurrentStep) - GradientShift)
  ComputeComponentGradient = NewValue
End Function
Function CombineWebColor(Red As Byte, Green As Byte, Blue As Byte) As Long
'this function is just to show you that vb does in fact contain a few useful
' built-in functions.
CombineWebColor = RGB(Red, Green, Blue)
End Function
Function CombineVBColor(Blue As Byte, Green As Byte, Red As Byte) As Long
'This is here simply to keep you from forgetting that web and vb are backwards to each other,
'  making a programming error less likely.
   CombineVBColor = RGB(Blue, Green, Red)
End Function
Function ComputeFadedVBColor(Starting As Long, Ending As Long, TotalSteps As Integer, CurrentStep As Integer)
   Dim StartingRed As Byte
   Dim StartingGreen As Byte
   Dim StartingBlue As Byte
   Dim EndingRed As Byte
   Dim EndingGreen As Byte
   Dim EndingBlue As Byte
   Dim FadedRed As Byte
   Dim FadedGreen As Byte
   Dim FadedBlue As Byte
   Call SplitVBColor(Starting, StartingBlue, StartingGreen, StartingRed)
   Call SplitVBColor(Ending, EndingBlue, EndingGreen, EndingRed)
   FadedRed = ComputeComponentGradient(StartingRed, EndingRed, TotalSteps, CurrentStep)
   FadedGreen = ComputeComponentGradient(StartingGreen, EndingGreen, TotalSteps, CurrentStep)
   FadedBlue = ComputeComponentGradient(StartingBlue, EndingBlue, TotalSteps, CurrentStep)
   ComputeFadedVBColor = CombineVBColor(FadedBlue, FadedGreen, FadedRed)
End Function
Function ComputeFadedWebColor(Starting As Long, Ending As Long, TotalSteps As Integer, CurrentStep As Integer)
   ComputeFadedWebColor = ComputeFadedVBColor(Starting, Ending, TotalSteps, CurrentStep)
End Function
Sub SplitWebHexToRGBHex(WebHex As String, Red As String, Green As String, Blue As String)
   WebHex = ZeroPad(WebHex)
   Red = Left$(WebHex, 2)
   Green = Mid$(WebHex, 3, 2)
   Blue = Right$(WebHex, 2)
End Sub
Sub SplitVBHexToRGBHex(VBHex As String, Blue As String, Green As String, Red As String)
   Call SplitWebHexToRGBHex(VBHex, Blue, Green, Red)
End Sub
Sub SplitWebHexToRGB(WebHex As String, Red As Byte, Green As Byte, Blue As Byte)
   Dim DeHexed As Long
   DeHexed = HexToLong(WebHex)
   Call SplitWebColor(DeHexed, Red, Green, Blue)
End Sub
Sub SplitVBHexToRGB(VBHex As String, Blue As Byte, Green As Byte, Red As Byte)
   Call SplitWebHexToRGB(VBHex, Blue, Green, Red)
End Sub