• Home
 · 
• Graphics
 · 
• Gradient colors for forms, listviews, pictureboxes, etc. Handles over a million colors with 16 diff

Gradient colors for forms, listviews, pictureboxes, etc. Handles over a million colors with 16 diff

Gradient colors for forms, listviews, pictureboxes, etc. Handles over a million colors with 16 different patterns.

API Declarations


Public Enum GradientType
Top_to_Bottom = 1
Left_to_Right = 2
Bottom_to_Top = 3
Right_to_Left = 4
Diamond_Center_FadeOut = 5
Diamond_Center_FadeIn = 6
Circle_Center_FadeOut = 7
Circle_Center_FadeIn = 8
Circle_Top_Left_FadeOut = 9
Circle_Top_Left_FadeIn = 10
Circle_Top_Right_FadeOut = 11
Circle_Top_Right_FadeIn = 12
Circle_Bottom_Left_FadeOut = 13
Circle_Bottom_Left_FadeIn = 14
Circle_Bottom_Right_FadeOut = 15
Circle_Bottom_Right_FadeIn = 16
End Enum



Rate Gradient colors for forms, listviews, pictureboxes, etc. Handles over a million colors with 16 diff

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

' 1 to do the coloring, 1 to convert numbers to hex & 1 to convert hex to RGB
'
Public Function DoGradient(ObjectID As Object, lColor As Long, GradientType As Integer, _
    Optional bkgPic As PictureBox, Optional bSolidsOnly As Boolean = False) As Boolean
'=======================================================================
'   'This will color any object with a AutoRedraw property in gradient colors or other objects that can
'  have a picture property
'   Required variables
'   - ObjID: this is the object to repaint, generally a form or picture box
'       Note: If the object doesn't have an AutoRedraw property, you may need to use the bkgPic parameter
'   - GradientType: required, a number between 1 & 16
'   - lColor: a valid color value in Long Integer format or Hex Format
'   - bkgPic: Optional. If trying to color a ListView control, it can't be colored directly, instead a hidden picturebox
'       on your form is formatted with the colors and the result is then applied to the ListView control
'       If trying to color any object without an AutoRedraw property, always supply a hiddent picturebox contol also
'   - bSolidsOnly: Optional. Will not color with gradients. Will simply change the background color of the control passed
'=======================================================================
On Error Resume Next
Dim sColor As String
Dim I As Integer, Y As Integer, PrevProps(1 To 4) As Long
Dim X As Single, X1 As Single, X2 As Single, ObjName As Object
Dim R As Integer, B As Integer, G As Integer, SW As Long, SH As Long
Dim Red As Integer, Blue As Integer, Green As Integer, bTransfer As Boolean
Dim LoopStart As Integer, LoopStop As Integer, iStepVal As Integer
    
Set ObjName = ObjectID                      ' set local object to target object
If bSolidsOnly = False Then
    ObjName.AutoRedraw = True                                       ' set this variable & if it returns an error,
    If Err.Number > 0 Then                                                  ' then we can't color it this way
        Err.Clear                                                                    ' but if a picturebox was provided, we can try
        If bkgPic Is Nothing Then                                              ' no picturebox to paint an image from
            ObjectID.BackColor = lColor                                 ' so change background color
            Exit Function
        End If
        bkgPic.Cls                                      ' trying to use the picture box method. Clear picturebox first
        bkgPic.Visible = False                     ' ensure it is hidden, since it will be resized
        bkgPic.AutoRedraw = True             ' resize to fit the target object
        bkgPic.Width = ObjName.Width
        bkgPic.Height = ObjName.Height
        Set ObjName = bkgPic                    ' set local object to the picturebox
        bTransfer = True                              ' flag for transfering colors to target object at end of routine
    End If
Else
    ObjectID.BackColor = CLng(sColor)   ' if coloring with solid colors only, do that & exit
    DoGradient = True
    Exit Function
End If

On Error GoTo GradientErrors
sColor = CStr(lColor)
sColor = ConvertToRGB(sColor)         ' Send hex or decimal number to be converted to an RGB string
Red = Val(Left(sColor, 3))                  ' Set the red color (0-255)
Green = Val(Mid(sColor, 4, 3))           ' set the green color
Blue = Val(Right(sColor, 3))                ' set the blue color
PrevProps(1) = ObjName.ScaleHeight      ' keep track of original scaleheight & scalemode values
PrevProps(2) = ObjName.ScaleWidth       ' this is important if other controls reference the object for
PrevProps(3) = ObjName.ScaleMode       ' resizing purposes -- other code out there failed to do this
' Set initial variables for gradient looping
LoopStart = 0: LoopStop = 255: iStepVal = 1
' Change the object properties before trying to color
ObjName.DrawMode = 13
ObjName.DrawWidth = 12
ObjName.ScaleMode = 3
ObjName.ScaleHeight = 256
ObjName.ScaleWidth = 256

' Now set other variables depending on what type of gradient pattern is being used
'   Note: You can add any other types of patterns simply by setting values here & adding that
'       pattern to the Public Enum in the declarations section above
Select Case GradientType
Case 1, 2, 3, 4     ' Horizontal or Vertical gradients
    SW = ObjName.ScaleWidth
    SH = ObjName.ScaleHeight
    If GradientType > 2 Then                     ' Reverse loop when fading in
        LoopStart = 255: LoopStop = 0
        iStepVal = -1
    End If
Case 5, 6               ' Diamonds
    SH = ObjName.ScaleHeight / 2
    SW = ObjName.ScaleWidth / 2
    If GradientType = 6 Then                    ' Reverse loop when fading in
        LoopStart = 255: LoopStop = 0
        iStepVal = -1
        ObjName.BackColor = 0
    Else
        ObjName.BackColor = lColor
    End If
Case Else               ' Circles
    Select Case GradientType
    Case 7, 8
        SH = ObjName.ScaleHeight / 2
        SW = ObjName.ScaleWidth / 2
    Case 9, 10
        SH = 0: SW = 0
    Case 11, 12
        SH = 0
        SW = ObjName.ScaleWidth
    Case 13, 14
        SH = ObjName.ScaleHeight
        SW = 0
    Case 15, 16
        SH = ObjName.ScaleHeight
        SW = ObjName.ScaleWidth
    End Select
    If GradientType Mod 2 = 0 Then                  ' Reverse loop when fading in
        LoopStart = 255: LoopStop = 0
        iStepVal = -1
        ObjName.BackColor = 0
    Else
        ObjName.BackColor = lColor
    End If
End Select
GoSub DrawLines
ObjName.ScaleHeight = PrevProps(1)                             ' reset original properties
ObjName.ScaleWidth = PrevProps(2)
ObjName.ScaleMode = PrevProps(3)
If bTransfer = True Then                                    ' Trying to color using the picturebox method
    ObjectID.PictureAlignment = lvwTile             ' If object supports tiling, set tiling
    Set ObjectID.Picture = bkgPic.Image            ' Set the background picture
    bkgPic.Cls                                                     ' Clear picture box
End If
Set ObjName = Nothing
DoGradient = True           ' return value of true
Exit Function
        
DrawLines:
    On Error Resume Next
    ObjName.Cls
    ' loop thru each color value & color the object
    For I = LoopStart To LoopStop Step iStepVal
        If I > Red Then R = Red Else R = I              ' if red value exceeded, use red value
        If I > Green Then G = Green Else G = I       ' if green value exceeded, use green value
        If I > Blue Then B = Blue Else B = I             ' if blue value exceeded, use blue value
        Select Case GradientType
        Case 1, 3   ' Top to bottom & left to right
            ObjName.Line (0, Y)-(SW, Y + 1), RGB(R, G, B), BF  ' paint line Y
        Case 2, 4   ' Bottom to top, & right to left
            ObjName.Line (Y, 0)-(Y + 1, SH), RGB(R, G, B), BF  ' paint line Y
        Case 5, 6   ' diamonds
            X = Y / 255
            X1 = 1 - X: X2 = 1 + X
            ObjName.Line (SW * X1, SH)-(SW, SH * X1), RGB(R, G, B)    ' Draw upper-left.
            ObjName.Line -(SW * X2, SH), RGB(R, G, B)  ' Draw upper-right.
            ObjName.Line -(SW, SH * X2), RGB(R, G, B)  ' Draw lower-right.
            ObjName.Line -(SW * X1, SH), RGB(R, G, B)  ' Draw lower-left.
        Case Else   ' circles
            ObjName.Circle (SW, SH), Y, RGB(R, G, B)
    End Select
        Y = Y + 1                                                   ' increment line counter
    Next I
Return

GradientErrors:
End Function

Private Function ConvertToRGB(HexLng As String) As String
'=======================================================================
'   'This will convert Hexidecimal color coding to RGB color coding
'       variables passed must either be numeric or in the format of &H########
'=======================================================================
' Inserted by LaVolpe
On Error GoTo Function_ConvertToRGB_General_ErrTrap_by_LaVolpe
If IsNumeric(Mid(HexLng, 2)) Then
    If Val(HexLng) < 0 Then HexLng = 255
    HexLng = BigDecToHex(HexLng)
End If
'For Convert Hexidecimal to RGB:  Converts Hexidecimal to RGB
On Error GoTo errorsub
Dim Tmp$
Dim lo1 As Integer, lo2 As Integer
Dim hi1 As Long, hi2 As Long
Const Hx = "&H"
Const BigShift = 65536
Const LilShift = 256, Two = 2
Tmp = HexLng
If UCase(Left$(HexLng, 2)) = "&H" Then Tmp = Mid$(HexLng, 3)
Tmp = Right$("0000000" & Tmp, 8)
If IsNumeric(Hx & Tmp) Then
lo1 = CInt(Hx & Right$(Tmp, Two))       ' Red
hi1 = CLng(Hx & Mid$(Tmp, 5, Two))   ' Green
lo2 = CInt(Hx & Mid$(Tmp, 3, Two))     ' blue
hi2 = CLng(Hx & Left$(Tmp, Two))
'ConvertToRGB = CCur(hi2 * LilShift + lo2) * BigShift + (hi1 * LilShift) + lo1
ConvertToRGB = Format(lo1, "000") & Format(hi1, "000") & Format(lo2, "000")
End If
Exit Function

errorsub:  MsgBox Err.Description, vbExclamation, "Error"
Exit Function

Function_ConvertToRGB_General_ErrTrap_by_LaVolpe:    ' Inserted by Lavolpe
If MsgBox("Error " & Err.Number & " - Procedure [Function ConvertToRGB]" & vbCrLf & Err.Description, vbExclamation + vbRetryCancel) = vbRetry Then Resume
End Function

Private Function BigDecToHex(ByVal DecNum) As String
'=======================================================================
'   Used to convert any decimal value to hex equivalent
'=======================================================================
    ' This function is 100% accurate untill
    '     15,000,000,000,000,000 (1.5E+16)
    Dim NextHexDigit As Double
    Dim HexNum As String

' Inserted by LaVolpe OnError Insertion Program.
On Error GoTo BigDecToHex_General_ErrTrap

HexNum = ""
While DecNum <> 0
    NextHexDigit = DecNum - (Int(DecNum / 16) * 16)
    If NextHexDigit < 10 Then
        HexNum = Chr(Asc(NextHexDigit)) & HexNum
    Else
        HexNum = Chr(Asc("A") + NextHexDigit - 10) & HexNum
    End If
    DecNum = Int(DecNum / 16)
Wend

If HexNum = "" Then HexNum = "0"
BigDecToHex = HexNum
Exit Function

' Inserted by LaVolpe OnError Insertion Program.
BigDecToHex_General_ErrTrap:
MsgBox "Err: " & Err.Number & " - Procedure: BigDecToHex" & vbCrLf & Err.Description, vbExclamation + vbOKOnly
End Function