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```

has posted a total of 1 articles.

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.