by Fastgraph boy (1 Submission)
Category: Graphics
Compatability: Visual Basic 3.0
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(5 Votes)
Displays a color wheel on your monitor.
VBcoders' Copyright © 2000 Phillip Senn
' Freely distribute
' Special thanks to:
' Lewis A. Shadoff, PhD http://websorcerer.com/h16/wheelie.html
Option Explicit
Const Radius = 127
Const PI = 3.14159265358979
Function ReduceTo255(nmbr, base) As Single
Dim hexVal As Integer
Dim dig1 As Integer
Dim dig2 As Integer
hexVal = nmbr * 255 / base
dig1 = hexVal Mod 16
dig2 = (hexVal - dig1) / 16
ReduceTo255 = dig2 * 16 + dig1
End Function
Function ColorValue(Color As String, ang As Single, vector As Single, xPos As Integer, yPos As Integer) As Single
'Calculate the color value for Red Green and Blue.
'Value is between 0 and 65535.
'For RED:
'In the area bounded by an angle of 60 degrees and 300 degrees value is 65535.
'(This is a right-hand-side quadrant)
'Outside this area the value decreases linearly from the boundary of the area to the edge of the circle on a line parallel to the x-axis.
'For GREEN:
'The coordinates must be rotated 120 degrees clockwise and x and y re-calculated.
'This transforms the circle so that the same calcualtion as for RED is valid.
'For BLUE:
'The coordinates are rotated 240 degrees.
Dim angCorr, angVal, xVal, yVal, X1, X2
If Color = "red.." Then angCorr = 0 * PI / 3
If Color = "green" Then angCorr = 2 * PI / 3
If Color = "blue." Then angCorr = 4 * PI / 3
angVal = ang - angCorr ' Apply rotation
If angVal < 0 Then angVal = angVal + 2 * PI ' If angle is negative, add 360 degrees
If Color = "red.." Then
xVal = xPos
yVal = yPos
Else
xVal = Abs(vector * Cos(angVal))
yVal = Abs(vector * Sin(angVal))
If angVal > PI / 2 And angVal < 3 * PI / 2 Then
xVal = -xVal ' Get the sign right
End If
End If
If angVal <= 2 * PI / 6 Or angVal >= 10 * PI / 6 Then
ColorValue = 65535 ' If inside the quadrant...
Else ' If outside the quadrant...
X1 = Sqr(Radius ^ 2 - yVal ^ 2) + xVal
X2 = Abs(yVal) / Tan(PI / 3) - xVal
ColorValue = 65535 * X1 / (X1 + X2)
End If
End Function
Private Sub Form_Activate()
'1) For each pixel within the Radius:
'2) Calculate vector, the distance from the center of the circle
'3) Calculate theta, the angle from the x-axis to the pixel (counterclockwise)
'4) Calculate the RGB values (0 to 65535)
'5) Convert to Hexadecimal values
'6) Place the pixel on the form
Dim cursX As Integer, cursY As Integer
Dim theta As Single
Dim thetaDeg As Single
Dim vector As Single
Dim X As Long, Y As Long
Dim R As Long, G As Long, B As Long ' Red, Green, Blue
X = Me.ScaleWidth / 2
Y = Me.ScaleHeight / 2
For cursX = -Radius To Radius
For cursY = Radius To -Radius Step -1
vector = Sqr(cursX * cursX + cursY * cursY)
If vector <= Radius Then
If vector = 0 Then vector = 1
theta = aSin(Abs(cursY / vector))
If cursX < 0 And cursY > 0 Then theta = 1 * PI - theta
If cursX > 0 And cursY > 0 Then theta = 1 * theta
If cursX < 0 And cursY < 0 Then theta = 1 * PI + theta
If cursX > 0 And cursY < 0 Then theta = 2 * PI - theta
thetaDeg = theta * 360 / 2 / PI
R = ColorValue("red..", theta, vector, cursX, cursY)
G = ColorValue("green", theta, vector, cursX, cursY)
B = ColorValue("blue.", theta, vector, cursX, cursY)
R = ReduceTo255(R, 65535)
G = ReduceTo255(G, 65535)
B = ReduceTo255(B, 65535)
Me.PSet (cursX + X, -cursY + Y), RGB(R, G, B)
End If
Next cursY
Next cursX
End Sub
Private Function aSin(ByRef X As Variant) As Single
If X = 1 Then
aSin = 0 ' This is why you see those red lines
Else
aSin = Atn(X / Sqr(-X * X + 1))
End If
End Function
Private Sub Form_Load()
Me.ScaleMode = vbPixels
Me.WindowState = vbMaximized
End Sub
