Draw a Gradient Either Horizontally, Vertically, or in a Circle

Category:

Screen/Graphics

Type:

Snippets

Difficulty:

Intermediate

Author:

Matt Beighton

Version Compatibility: Visual Basic 6, Visual Basic 5

More information:

Using the line function this module creates a gradient fill on eeither a form or picture box, fades from an rgb color to another. At the moment it is a little bit slow, but i hope to improve that soon. Can be used to make setup screens. Set the object's autoredraw property to true so the gradient stays persistent.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
'

Code:

Public Sub Gradient(Object As Object, R1 As Integer, G1 As Integer, B1 As Integer, R2 As Integer, G2 As Integer, B2 As Integer, Direction As Integer)

On Error Resume Next
Y = 0
X = 0
Z = 0
A = 0
Dim B, G, R As Double
Dim BI, GI, RI As Double
R = R1
G = G1
B = B1

If Direction = 0 Then GoTo Horizontal
If Direction = 1 Then GoTo Vertical
If Direction = 2 Then GoTo Sphere
If Direction = 3 Then GoTo Angle

Horizontal:
RI = (R2 - R1) / Object.Height
GI = (G2 - G1) / Object.Height
BI = (B2 - B1) / Object.Height
Do Until Y >= Object.Height
Object.Line (0, Y)-(Object.Width, Y), RGB(R, G, B)
Y = Y + 1
R = R + RI
G = G + GI
B = B + BI
Loop
Exit Sub

Vertical:
RI = (R2 - R1) / Object.Width
GI = (G2 - G1) / Object.Width
BI = (B2 - B1) / Object.Width
Do Until Y >= Object.Width
Object.Line (Y, 0)-(Y, Object.Height), RGB(R, G, B)
Y = Y + 1
R = R + RI
G = G + GI
B = B + BI
Loop
Exit Sub

Sphere:
Dim Radius
RI = (R2 - R1) / Object.Width
GI = (G2 - G1) / Object.Width
BI = (B2 - B1) / Object.Width
Radius = 1
Xpos = Object.ScaleWidth / 2
Ypos = Object.ScaleHeight / 2
Do Until Radius >= Object.Width
Object.Circle (Xpos, Ypos), Radius, RGB(R, G, B)
Object.Circle (Xpos, Ypos), Radius + 1, RGB(R + 1, G + 1, B + 1)
Object.Circle (Xpos, Ypos), Radius + 2, RGB(R + 1, G + 1, B + 1)
Radius = Radius + 3
R = R + (RI * 3)
G = G + (GI * 3)
B = B + (BI * 3)
Loop
Exit Sub

Angle:
Dim Hypotenuse As Double
Dim Calc As Double
Calc = (Object.ScaleWidth ^ 2 + Object.ScaleHeight ^ 2)
Hypotenuse = Sqr(Calc) + ((Object.ScaleHeight / 100) * 12)

'Sqr(((Object.Height * Object.Height) + (Object.Width * Object.Width)))

RI = (R2 - R1) / Hypotenuse
GI = (G2 - G1) / Hypotenuse
BI = (B2 - B1) / Hypotenuse
Do Until Z >= Object.Height And A >= Object.Width
Object.Line (X, Z)-(A, Y), RGB(R, G, B)
R = R + (RI)
G = G + (GI)
B = B + (BI)
Y = Y + 1
X = X + 1
If X >= Object.Width Then Z = Z + 1
If Y >= Object.Height Then A = A + 1
Loop

End Sub