VBA
Standard module
Specify location and size, and optionally background color and start/end angles.
'*************** Code Start ***************************************************
' Purpose : draw a Rainbow on an Access report
' specify report object,
' coordinate of the middle of the Rainbow circle,
' and radius of the rainbow.
' Optionally set background color,
' and start and end angles
' USES the Circle method
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Draw_Rainbow.htm
' Report Draw Reference: https://msaccessgurus.com/VBA/ReportDraw_Reference.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
' bas_Draw_Rainbow_s4p
'------------------------------------------------------------------------------
' Global variables
'------------------------------------------------------------------------------
'comment if defined elsewhere
Public Const PI As Double = 3.14159
Public Const gZero As Single = 0.0000001
Private ColorRainbow(1 To 9) As Long
'------------------------------------------------------------------------------
' Draw_Rainbow_s4p
' send report object, center coordinate of rainbow circle and radius
'------------------------------------------------------------------------------
Public Sub Draw_Rainbow_s4p(poReport As Report _
,pXCenter As Single _
,pYCenter As Single _
,psgRadius As Single _
,Optional pnColorBackground As Long = vbWhite _
,Optional psgAngle1 As Single = gZero _
,Optional psgAngle2 As Single = PI _
)
'230116 s4p
'Draw a Rainbow
' measurements in twips and radians
'PARAMETERs
' poReport is the Report object
' pXCenter is x-coordinate of the middle of the Rainbow circle
' pYCenter is y-coordinate of the middle of the Rainbow circle
' psgRadius is Rainbow radius
'(Optional)
' pnColorBackground, default is white
' psgAngle1 start angle, default is zero
' psgAngle2 end angle, default is PI
On Error GoTo Proc_Err
'dimension variables
Dim sgRadius As Single _
,i As Integer
If ColorRainbow(1) = 0 Then
Call setColorsRainbow
End If
'background color in the middle
ColorRainbow(9) = pnColorBackground
If psgAngle1 = 0 Then
If psgAngle2 = 0 Then
Exit Sub
End If
'zero can't be negative -- use small number
psgAngle1 = gZero
End If
With poReport
.ScaleMode = 1 'twips
.DrawWidth = 1 'pixel
.FillStyle = 0 'Opaque
sgRadius = psgRadius
For i = 1 To 9
.FillColor = ColorRainbow(i)
'negative angles mean to close the shape
'so it can be filled
poReport.Circle (pXCenter,pYCenter),sgRadius _
,ColorRainbow(i),-psgAngle1,-psgAngle2
If i = 1 Or i = 8 Then
sgRadius = sgRadius - psgRadius / 30 'thin border
Else
sgRadius = sgRadius - psgRadius / 15
End If
Next i
End With 'poReport
Proc_Exit:
On Error GoTo 0
Exit Sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " Draw_Rainbow_s4p"
Resume Proc_Exit
Resume
End Sub
'------------------------------------------------------------------------------
' setColorsRainbow
'------------------------------------------------------------------------------
Sub setColorsRainbow()
ColorRainbow(1) = RGB(208,57,46) 'dark Red
ColorRainbow(2) = RGB(244,67,54) 'Red
ColorRainbow(3) = RGB(255,152,0) 'Orange
ColorRainbow(4) = RGB(255,235,59) 'Yellow
ColorRainbow(5) = RGB(139,195,74) 'Green
ColorRainbow(6) = RGB(33,150,243) 'Blue
ColorRainbow(7) = RGB(153,0,255) 'Violet
ColorRainbow(8) = RGB(99,50,159) 'dark Violet
End Sub
'*************** Code End *****************************************************
Goto Top
rpt_Rainbow_Detail
Code behind report to draw portions of a Rainbow based on status.
'*************** Code Start CBR ***********************************************
' Purpose : code behind rpt_Rainbow_Detail
' calls Draw_Rainbow_s4p
' draw portions of a rainbow
' fractions of PI defined in a table for stand and end angles
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Draw_Rainbow.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Detail_Format
'------------------------------------------------------------------------------
Private Sub Detail_Format(Cancel As Integer,FormatCount As Integer)
'230116 crystal
'draw portions of rainbows in the detail section of a report
'CALLs
' Draw_Rainbow_s4p
Dim X As Single,Y As Single _
,dx As Single,dy As Single _
,sgRadius As Single _
,sgAngle1 As Single _
,sgAngle2 As Single
With Me
.ScaleMode = 1 'twips
'width and height for drawing
dx = 2 * 1440 '1440 twips/inch
dy = .ScaleHeight
sgRadius = 1440 '1 inch
'center of rainbow circle
X = .ScaleLeft + dx / 2
Y = .ScaleTop + sgRadius
sgAngle1 = .StartPI * PI
sgAngle2 = .EndPI * PI
End With
'Call Draw_Rainbow_s4p
Call Draw_Rainbow_s4p(Me,X,Y,sgRadius,,sgAngle1,sgAngle2)
End Sub
'*************** Code End *****************************************************
Goto Top
rpt_Rainbow_Page
Code behind report to draw a rainbow at the top of a page.
'*************** Code Start CBR ***********************************************
' Purpose : code behind rpt_rainbows_Page
' calls Draw_Rainbow_s4p
' draw a rainbow on a page
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Draw_Rainbows.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'------------------------------------------------------------------------------
' Report_Page
'------------------------------------------------------------------------------
Private Sub Report_Page()
'230115 crystal
'draw a rainbow at the top of the page
'CALLs
' Draw_Rainbow_s4p
Dim X As Single,Y As Single _
,dx As Single,dy As Single _
,sgRadius As Single
With Me
.ScaleMode = 1 'twips
'width and height for drawing
dx = .ScaleWidth
dy = .ScaleHeight _
- .PageFooterSection.Height _
- .PageHeaderSection.Height
If dx > dy Then
sgRadius = dy / 2
Else
sgRadius = dx / 2
End If
'center of rainbow
X = .ScaleLeft + dx / 2
Y = .ScaleTop + .PageHeaderSection.Height _
+ sgRadius
End With
'Call Draw_Rainbow_s4p
Call Draw_Rainbow_s4p(Me,X,Y,sgRadius)
End Sub
'*************** Code End *****************************************************
' Code was generated with colors using the free
Color Code add-in for Access.
