Drawing Gradients in VB6

Posted On 2018-03-13 by MattBeighton
Keywords:
Tags: VB6 Graphics VB6 Miscellaneous 
Views: 77


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


About the Author

has posted a total of 1 articles.


Comments On This Post

No comments on this post yet!


Do you have a thought relating to this post? You can post your comment here. If you have an unrelated question, you can use the Q&A section to ask it.

Or you can drop a note to the administrators if you're not sure where you should post.


Your IP address is:54.166.141.12

Before you can post, you need to prove you are human. If you log in, this test goes away.


Code Links