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
Update
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 'red Dim ta1 As Double, tb1 As Double, tc1 As Double, td1 As Double 'green Dim ta2 As Double, tb2 As Double, tc2 As Double, td2 As Double 'blue 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 Update 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) Update End Sub
