Color Bar code


from the bottom up, here is the sub procedure to draw a rectangle, coordinates x1, y1, x2, y2, with a solid hatch of color RGB

Sub draw_color_rect(x1 As Double, y1 As Double, x2 As Double, y2 As Double, i_r As Integer, i_g As Integer, i_b As Integer)
Dim color As AcadAcCmColor
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.20")
Call color.SetRGB(i_r, i_g, i_b)
Dim objhatch As AcadHatch
Dim outerloop(0 To 0) As AcadEntity
Dim plineobj As AcadLWPolyline
Dim pt(0 To 7) As Double

pt(0) = x1
pt(1) = y1
pt(2) = x2
pt(3) = y1
pt(4) = x2
pt(5) = y2
pt(6) = x1
pt(7) = y2

Set plineobj = acadDoc.ModelSpace.AddLightWeightPolyline(pt)
plineobj.Closed = True
Set outerloop(0) = plineobj
plineobj.TrueColor = color

Set objhatch = acadDoc.ModelSpace.AddHatch(1, "Solid", True)
     objhatch.AppendOuterLoop outerloop
     objhatch.TrueColor = color
End Sub

We call this rectangle drawing sub with a loop program with variable X from 0 to 360. X represents degrees, each rectangle is one X wide. The colors in the rectangle are a function of a Sin function that uses the X value as degree. We use a variation of the Sin function to calculate different values for R G and B.

Sub colorbar()
Call connect_acad

Dim x1 As Double, y1 As Double
Dim x2 As Double, y2 As Double
Dim x As Integer
Dim i_r As Integer, i_g As Integer, i_b As Integer

Dim ta1 As Double, tb1 As Double, tc1 As Double, td1 As Double
Dim ta2 As Double, tb2 As Double, tc2 As Double, td2 As Double
Dim ta3 As Double, tb3 As Double, tc3 As Double, td3 As Double

With frm_Color_Wheel
ta1 = .txt_a1
tb1 = .txt_b1
tc1 = .txt_c1
td1 = .txt_d1

ta2 = .txt_a2
tb2 = .txt_b2
tc2 = .txt_c2
td2 = .txt_d2

ta3 = .txt_a3
tb3 = .txt_b3
tc3 = .txt_c3
td3 = .txt_d3

y1 = .txt_y1
y2 = .txt_y2
End With
For x = 0 To 360
i_r = ta1 * Sin(deg2rad(tb1 * x + tc1)) + td1
i_g = ta2 * Sin(deg2rad(tb2 * x + tc2)) + td2
i_b = ta3 * Sin(deg2rad(tb3 * x + tc3)) + td3

'error checking and correction
'cannot pass any RGB value not 0 <= x <= 255
If Not (i_r >= 0 And i_r <= 255) Then
Debug.Print "i_r = " & i_r
End If

If Not (i_g >= 0 And i_g <= 255) Then
Debug.Print "i_g = " & i_g
End If

If Not (i_b >= 0 And i_b <= 255) Then
Debug.Print "i_b = " & i_b
End If

If i_r < 0 Then i_r = 0
If i_r > 255 Then i_r = 255

If i_g < 0 Then i_g = 0
If i_g > 255 Then i_g = 255

If i_b < 0 Then i_b = 0
If i_b > 255 Then i_b = 255
'Debug.Print i & ", " & i_r & ", " & i_g & ", " & i_b

x1 = x
x2 = x + 1
Call draw_color_rect(x1, y1, x2, y2, i_r, i_g, i_b)
Next x

End Sub

How exactly we fill the values for the 3 separate Sin functions, it could be done many different ways. The top left part of the form takes care of this. the values can also be input manually, or a canned formula can be tweaked manually. the program reads the values in the textboxes, however they got there. I made a second reference form to show the graph shapes. I arbitrarily lined them up four to a row and assigned them numbers. the user checks the color radio button, checks the number, then pushes the Fill Equation button. The button Set Form will put in starter values for every textbox on the form.

the button Draw Charts will draw the graph of each function in its own color.


DrawCharts can be simpler than the normal graphing function because it is special purpose, always graphing Y= a (Sin bX + c) + d. I added a yscl variable to optionally mash it down to make screenshots show more of the color bar and less of the chart. It calls a NewLayer routine not shown to create a layer for each chart using the color being graphed and a heavy lineweight to show up better.

Sub drawcharts()
On Error Resume Next
Dim strname As String
acadDoc.SetVariable "LWDISPLAY", 1

a = frm_Color_Wheel.txt_a1.Value
b = frm_Color_Wheel.txt_b1.Value
c = frm_Color_Wheel.txt_c1.Value
d = frm_Color_Wheel.txt_d1.Value
strname = "Red"
Call newlayer(strname, 1, acLnWt035)
acadDoc.ActiveLayer = acadDoc.Layers.Item(strname)
Call drawchart1(a, b, c, d)

a = frm_Color_Wheel.txt_a2.Value
b = frm_Color_Wheel.txt_b2.Value
c = frm_Color_Wheel.txt_c2.Value
d = frm_Color_Wheel.txt_d2.Value
strname = "Green"
Call newlayer(strname, 3, acLnWt035)
acadDoc.ActiveLayer = acadDoc.Layers.Item(strname)
Call drawchart1(a, b, c, d)

a = frm_Color_Wheel.txt_a3.Value
b = frm_Color_Wheel.txt_b3.Value
c = frm_Color_Wheel.txt_c3.Value
d = frm_Color_Wheel.txt_d3.Value
strname = "Blue"
Call newlayer(strname, 5, acLnWt035)
acadDoc.ActiveLayer = acadDoc.Layers.Item(strname)
Call drawchart1(a, b, c, d)

End Sub

Sub drawchart1(a As Double, b As Double, c As Double, d As Double)
Dim pt() As Double
Dim plineobj As AcadLWPolyline
Dim numpts As Integer
Dim x As Integer
Dim y As Double
Dim yscl As Double

numpts = 361
ReDim pt(1 To numpts * 2)  'store x and y for one pt
yscl = frm_Color_Wheel.txt_yscl.Value

For x = 0 To 360
y = a * Sin(deg2rad(b * x + c)) + d

If yscl <> 1 Then
y = y * yscl
End If

pt(x * 2 + 1) = x: pt(x * 2 + 2) = y
Next x

Set plineobj = acadDoc.ModelSpace.AddLightWeightPolyline(pt)
End Sub

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

This site uses Akismet to reduce spam. Learn how your comment data is processed.