VB - Gradient Circle

This code will create a gradient circle using the color, position, and radius that you want. (Currently only works on a VB form!!)

Code:

VB Code:

Public Function gradCircle(x, Y, circleRadius, colorRed, colorGreen, colorBlue, deForm As Form)
 
'Define some variables
Dim cirStop As Integer
cirStop = 50
 
'If function works fine, result is 0
gradCircle = 0
 
'Get color numbers (0-255)
redColor = colorRed
blueColor = colorBlue
greenColor = colorGreen
 
 
'Get current AutoRedraw property
defaultAutoRedraw = deForm.AutoRedraw
'Set AuroRedraw so circle can be created
deForm.AutoRedraw = True
 
 
'Check for illegal numbers
If redColor > 255 Or redColor < 0 Or blueColor > 255 Or blueColor < 0 Or greenColor > 256 Or greenColor < 0 Then
 gradCircle = 1
 Exit Function
End If
 
If redColor >= blueColor And redColor >= greenColor Then topCol = redCol
If blueColor >= redColor And blueColor >= greenColor Then topCol = blueCol
If greenColor >= redColor And greenColor >= blueColor Then topCol = greenCol
If topCol = 0 Then topCol = 255
 
'Obtain proper subtraction number for gradient
If cirStop = 0 Then
 subBy = topCol / circleRadius
 Else
  subBy = cirStop / circleRadius
End If
 
 
 'Draw circle
 
 For i = 1 To circleRadius
 deForm.Circle (x, Y), i, RGB(redColor, greenColor, blueColor)
 
 'Check if red has reached the stop number
 If redColor > cirStop Then
  redColor = redColor - subBy
  Else
   redDone = "yes"
 End If
 
  'Check if blue has reached the stop number
 If blueColor > cirStop Then
  blueColor = blueColor - subBy
  Else
   blueDone = "yes"
 End If
 
  'Check if green has reached the stop number
 If greenColor > cirStop Then
  greenColor = greenColor - subBy
  Else
   greenDone = "yes"
 End If
 
  'If all colors have reached the stop number, exit loop
 If redDone = "yes" And blueDone = "yes" And greenDone = "yes" Then Exit For
Next i
 
 
'Reset the AutoRedraw property to normal
deForm.AutoRedraw = defaultAutoRedraw
End Function

Usage:

VB Code:

Call gradCircle(xPosition, yPosition, Radius, RedRGB, GreenRGB, BlueRGB, theVBFormName)

This function will return '0' for a succesfull drawing and a '1' for a non-succesfull one.

If you modify this code please email me the new code at [email protected]

Cjqp

Very interesting. It needs work regarding defining variables (Option Explicit breaks it right off), and the function call requires the actual form as the last arg, not the form name.

But I like it!

There is a pattern of pixels that are not drawn at about 315 and 135 degrees, radiating from the center. Any ideas why that is?

I now realize some of the coding mistakes I made in this piece, I was relatively new to VB when I wrote it.

The best reasoning I have for the undrawn pixels lies with VB's Circle algorithem. I found that to fill these in, you can draw four gradient circles with 1px offset:

Code:

---

Call gradCircle(xPosition, yPosition, Radius, RedRGB, GreenRGB, BlueRGB, theVBFormName)
Call gradCircle(xPosition-1, yPosition, Radius, RedRGB, GreenRGB, BlueRGB, theVBFormName)
Call gradCircle(xPosition, yPosition-1, Radius, RedRGB, GreenRGB, BlueRGB, theVBFormName)
Call gradCircle(xPosition-1, yPosition-1, Radius, RedRGB, GreenRGB, BlueRGB, theVBFormName)

---

Here's your code fixed:

VB Code:

Option Explicit
 
Private Sub Form_Load()
    gradCircle 4000, 4000, 1000, 0, 250, 0, Me
End Sub
 
Public Function gradCircle(ByVal X As Single, ByVal Y As Single, ByVal circleRadius As Single, _
          ByVal colorRed As Byte, ByVal colorGreen As Byte, ByVal colorBlue As Byte, deForm As Form)
    Dim redColor As Single
    Dim blueColor As Single
    Dim greenColor As Single
    Dim defaultAutoRedraw As Boolean
    Dim topCol As Long, subBy As Single
    Dim I As Long
    Dim redDone As String, blueDone As String, greenDone As String
    
    'Define some variables
    Dim cirStop As Integer
    cirStop = 50
    
    'If function works fine, result is 0
    gradCircle = 0
    
    'Get color numbers (0-255)
    redColor = colorRed
    blueColor = colorBlue
    greenColor = colorGreen
    
    'Get current AutoRedraw property
    defaultAutoRedraw = deForm.AutoRedraw
    'Set AuroRedraw so circle can be created
    deForm.AutoRedraw = True
    deForm.DrawWidth = 2
    
    'Check for illegal numbers
    If redColor > 255 Or redColor < 0 Or blueColor > 255 Or blueColor < 0 Or greenColor > 256 Or greenColor < 0 Then
        gradCircle = 1
        Exit Function
    End If
    
    If redColor >= blueColor And redColor >= greenColor Then topCol = redColor
    If blueColor >= redColor And blueColor >= greenColor Then topCol = blueColor
    If greenColor >= redColor And greenColor >= blueColor Then topCol = greenColor
    
    If topCol = 0 Then topCol = 255
    
    'Obtain proper subtraction number for gradient
    If cirStop = 0 Then
        subBy = topCol / circleRadius
    Else
        subBy = cirStop / circleRadius
    End If
    
    'Draw circle
    For I = 1 To circleRadius
        deForm.Circle (X, Y), I, RGB(redColor, greenColor, blueColor)
        
        'Check if red has reached the stop number
        If redColor > cirStop Then
            redColor = redColor - subBy
        Else
            redDone = "yes"
        End If
        
        'Check if blue has reached the stop number
        If blueColor > cirStop Then
            blueColor = blueColor - subBy
        Else
            blueDone = "yes"
        End If
        
        'Check if green has reached the stop number
        If greenColor > cirStop Then
            greenColor = greenColor - subBy
        Else
            greenDone = "yes"
        End If
        
        'If all colors have reached the stop number, exit loop
        If redDone = "yes" And blueDone = "yes" And greenDone = "yes" Then Exit For
    Next I
    
    'Reset the AutoRedraw property to normal
    deForm.AutoRedraw = defaultAutoRedraw
End Function

And since you inspired me, here's mine:

VB Code:

Option Explicit
 
Private Type tCol_32_8
    R As Byte
    G As Byte
    B As Byte
    NotUsed As Byte
End Type
 
Private Type tCol_32
    Lng As Long
End Type
 
Public Sub DrawGradient(ByVal X As Single, ByVal Y As Single, ByVal Radius As Single, _
        ByVal FromCol As Long, ByVal ToCol As Long, Obj As Object)
    Dim FromRGB As tCol_32_8, ToRGB As tCol_32_8, ConvRGB As tCol_32
    Dim RS As Single, GS As Single, BS As Single
    Dim CurrColR As Single, CurrColG As Single, CurrColB As Single
    Dim I As Single, ObjPrevDrawWidth As Integer
    
    ObjPrevDrawWidth = Obj.DrawWidth
    Obj.DrawWidth = 2
    
    ConvRGB.Lng = FromCol
    LSet FromRGB = ConvRGB
    
    ConvRGB.Lng = ToCol
    LSet ToRGB = ConvRGB
    
    CurrColR = FromRGB.R
    CurrColG = FromRGB.G
    CurrColB = FromRGB.B
    
    RS = (CSng(ToRGB.R) - CSng(FromRGB.R)) / Radius
    GS = (CSng(ToRGB.G) - CSng(FromRGB.G)) / Radius
    BS = (CSng(ToRGB.B) - CSng(FromRGB.B)) / Radius
    
    For I = 1 To Radius
        Obj.Circle (X, Y), I, RGB(CurrColR, CurrColG, CurrColB)
        
        CurrColR = CurrColR + RS
        CurrColG = CurrColG + GS
        CurrColB = CurrColB + BS
    Next I
    
    Obj.DrawWidth = ObjPrevDrawWidth
End Sub
 
Private Sub Form_Load()
    Me.AutoRedraw = True
    DrawGradient 4000, 4000, 1000, RGB(100, 0, 0), RGB(20, 20, 180), Me
End Sub

If you notice, I changed the drawing object type to "Object", therefore you can pass to it a Form object, or PictureBox object, and it will still work...

Hey CVMichael,

I copied/pasted your 'inspired' code into a form in a new project and ran it.

Worked great except for the part where it draws something! :bigyello:

It looks great on the surface, and options to set the fade colors is pretty cool too.

Any ideas?

Quote:

---

Originally Posted by rjbudz

Worked great except for the part where it draws something! :bigyello:

Any ideas?

---

What do you mean, what did not work ?

The code ran, but there was no result. Nothing drew on the form

Set AutoRedraw = True...

I did not do that in code because if you use the same function from Form_Paint it will slow down the code a lot, so I let it up to the user...

Edit, I changed the code in post #4, and I added the line "Me.AutoRedraw = True", so no more confusions...

Sweet!

I'm uploading a toy I built with the finalized code. It uses scrollbars to adjust the RGB values of the inner and outer parts of the sphere, and the same for the Picture Box control that contains it. I'm sure someone will be able to use it for something. If not just to look at all the pretty colors :)