Drawing Gradients in VB6
This module uses the line function to create a gradient fill on either a form or picture box, fades from one 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 objects auto-redraw property to true so the gradient stays persistent.
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
Loading Comments ...
Comments
No comments have been added for this post.
You must be logged in to make a comment.