by LaVolpe (66 Submissions)
Category: Graphics
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Mon 17th September 2001
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
' 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
No comments have been posted about Gradient colors for forms, listviews, pictureboxes, etc. Handles over a million colors with 16 diff. Why not be the first to post a comment about Gradient colors for forms, listviews, pictureboxes, etc. Handles over a million colors with 16 diff.
