VBA
Standard module
Specify the report object,
the XY coordinates of the dial center,
the radius,
value (fraction or percentage),
and optionally a color for the center,
and ratio of center to the total size.
Linear measurements are in twips (TWenty In a Point).
'*************** Code Start *****************************************************
' module: mod_Draw_Dial_s4p
'-------------------------------------------------------------------------------
' Purpose : Draw a Dial on an Access report
' Author : crystal (strive4peace)
' License : below code
' Code List: msaccessgurus.com/code.htm
' This code: http://msaccessgurus.com/VBA/Code/DrawDial.htm
'-------------------------------------------------------------------------------
' global variables
'-------------------------------------------------------------------------------
'comment if defined elsewhere
Public ganColorRedOrangeYellowGreen30(1 To 30) As Long
Public Const TWIPperINCH As Long = 1440
Public Const PI As Double = 3.14159
Public Const gZero As Double = 0.0000001
'-------------------------------------------------------------------------------
' Draw_Dial_s4p
'-------------------------------------------------------------------------------
Sub Draw_Dial_s4p(oReport As Report _
,pXCenter As Single,pYCenter As Single _
,pRadius As Single _
,Optional psgValue As Variant = -1 _
,Optional pnColorCenter As Long = vbWhite _
,Optional psgRatio As Single = 0.6 _
)
'220617 strive4peace, 230414
'draw a dial with 30 colors from Red to Orange to Yellow to Green
'dial starts in SW quadrant
'PARAMETERS
' oReport is the Report object
' pXCenter is the center of dial in twips for the x-coordinate
' pYCenter is the center of dial in twips for the y-coordinate
' pRadius is the circle radius in twips
'OPTIONAL PARAMETERS
' psgValue is a percent % or fraction --
' defined as variant so it can be null
' pnColorCenter is the long integer color number for the middle
' psgRatio = ratio of inside circle to circle
If psgValue > 1 Then 'value can't be greater than 100%
psgValue = 1
ElseIf IsNull(psgValue) Then
psgValue = -1 'don't show needle
End If
Dim sgRadiusInside As Single _
,sgRadiusNeedle As Single _
,x1 As Single,y1 As Single _
,x2 As Single,y2 As Single _
,sgAngle As Single _
,sgAngle1 As Single _
,sgAngle2 As Single _
,sgStartAngle As Single _
,sgWedgeAngle As Single _
,sgTickAngle As Single _
,i As Integer _
,iQty As Integer _
,nColorNeedle As Long
Dim iGapDegree As Integer _
,sgGapAngle As Single
If ganColorRedOrangeYellowGreen30(1) = 0 Then
'set colors if not yet defined
Call SetColors_RedOrangeYellowGreen30
End If
iQty = 30 'number of wedges - depends on number of colors
sgTickAngle = 1 / 180 * PI 'spacing between wedges for tick marks
iGapDegree = 60 'gap at bottom
sgGapAngle = iGapDegree / 180 * PI
sgWedgeAngle = ((PI * 2) - sgGapAngle) / iQty
sgStartAngle = 1.5 * PI - sgGapAngle / 2 '270° - half gap
nColorNeedle = RGB(0,0,255) 'blue 16711680
With oReport
.ScaleMode = 1 'twips
.DrawWidth = 1 'pixel
.FillStyle = 0 'Opaque
sgAngle2 = sgStartAngle
'draw colored wedges for the dial
For i = 1 To 30
sgAngle1 = sgAngle2 - sgWedgeAngle
'do this so it can be negative
If sgAngle1 = 0 Then
sgAngle1 = gZero
End If
'Circle angle: 0 to 2 pi
' starts at sgStartAngle and goes backward
' to be clockwise
.FillColor = ganColorRedOrangeYellowGreen30(i)
oReport.Circle (pXCenter,pYCenter) _
,pRadius _
,ganColorRedOrangeYellowGreen30(i) _
,-(sgAngle1 + sgTickAngle) _
,-(sgAngle2 - sgTickAngle)
If sgAngle1 < 0.0001 Then
sgAngle2 = 2 * PI - gZero
Else
sgAngle2 = sgAngle1
End If
Next i
'draw center circle in the middle
.FillColor = pnColorCenter
sgRadiusInside = psgRatio * pRadius
oReport.Circle (pXCenter,pYCenter) _
,sgRadiusInside _
,pnColorCenter
'draw needle
If psgValue >= 0 Then
'round end
sgRadiusNeedle = pRadius * 0.15
'find the angle for the value
sgAngle = sgStartAngle - _
(((2 * PI) - sgGapAngle) _
* psgValue)
If sgAngle < 0 Then
sgAngle = sgAngle + (2 * PI)
End If
x1 = pXCenter + Cos(sgAngle) _
* (sgRadiusInside - sgRadiusNeedle * 1.5)
y1 = pYCenter - Sin(sgAngle) _
* (sgRadiusInside - sgRadiusNeedle * 1.5)
'draw circle
.FillColor = nColorNeedle
sgRadiusInside = psgRatio * pRadius
oReport.Circle (x1,y1) _
,sgRadiusNeedle _
,nColorNeedle
'outside coordinate for needle
x2 = pXCenter + Cos(sgAngle) _
* pRadius
y2 = pYCenter - Sin(sgAngle) _
* pRadius
'draw blue line for needle
.DrawWidth = 10
oReport.Line (x1,y1)-(x2,y2),nColorNeedle
End If 'needle
End With
Proc_Exit:
On Error GoTo 0
Exit Sub
Proc_Err:
MsgBox Err.Description,,_
"ERROR " & Err.Number _
& " Draw_Dial_s4p "
Resume Proc_Exit
Resume
End Sub
'-------------------------------------------------------------------------------
' SetColors_RedOrangeYellowGreen30
'-------------------------------------------------------------------------------
Public Sub SetColors_RedOrangeYellowGreen30()
ganColorRedOrangeYellowGreen30(1) = 2763685 'RGB: 165, 43, 42
ganColorRedOrangeYellowGreen30(2) = 2105532 'RGB: 188, 32, 32
ganColorRedOrangeYellowGreen30(3) = 1382098 'RGB: 210, 22, 21
ganColorRedOrangeYellowGreen30(4) = 658408 'RGB: 232, 11, 10
ganColorRedOrangeYellowGreen30(5) = 255 'RGB: 255, 0, 0
ganColorRedOrangeYellowGreen30(6) = 10751 'RGB: 255, 41, 0
ganColorRedOrangeYellowGreen30(7) = 21247 'RGB: 255, 82, 0
ganColorRedOrangeYellowGreen30(8) = 31999 'RGB: 255, 124, 0
ganColorRedOrangeYellowGreen30(9) = 42495 'RGB: 255, 165, 0
ganColorRedOrangeYellowGreen30(10) = 42495 'RGB: 255, 176, 0
ganColorRedOrangeYellowGreen30(11) = 48383 'RGB: 255, 188, 0
ganColorRedOrangeYellowGreen30(12) = 54015 'RGB: 255, 210, 0
ganColorRedOrangeYellowGreen30(13) = 59647 'RGB: 255, 232, 0
ganColorRedOrangeYellowGreen30(14) = 65535 'RGB: 255, 244, 0
ganColorRedOrangeYellowGreen30(15) = 65535 'RGB: 255, 255, 0
ganColorRedOrangeYellowGreen30(16) = 1375480 'RGB: 248, 252, 20
ganColorRedOrangeYellowGreen30(17) = 2685680 'RGB: 240, 250, 40
ganColorRedOrangeYellowGreen30(18) = 4061417 'RGB: 233, 248, 61
ganColorRedOrangeYellowGreen30(19) = 5371362 'RGB: 226, 246, 71
ganColorRedOrangeYellowGreen30(20) = 5371362 'RGB: 226, 245, 81
ganColorRedOrangeYellowGreen30(21) = 4841658 'RGB: 186, 224, 73
ganColorRedOrangeYellowGreen30(22) = 4312210 'RGB: 146, 204, 65
ganColorRedOrangeYellowGreen30(23) = 3782761 'RGB: 105, 184, 57
ganColorRedOrangeYellowGreen30(24) = 3253057 'RGB: 65, 163, 49
ganColorRedOrangeYellowGreen30(25) = 3253057 'RGB: 65, 150, 45
ganColorRedOrangeYellowGreen30(26) = 2722362 'RGB: 58, 138, 41
ganColorRedOrangeYellowGreen30(27) = 2191923 'RGB: 51, 114, 33
ganColorRedOrangeYellowGreen30(28) = 1661484 'RGB: 44, 102, 28
ganColorRedOrangeYellowGreen30(29) = 1130789 'RGB: 37, 84, 21
ganColorRedOrangeYellowGreen30(30) = 1130789 'RGB: 37, 65, 17
End Sub
'*************** Code End *******************************************************
Call from code behind report r_DIAL_Numberz
Uses a table with numbers (Numberz)
to get values for this example
'*************** Code Start *****************************************************
' code behind report: r_DIAL_Numberz
' Report Draw Reference:
' http://msaccessgurus.com/VBA/ReportDraw_Reference.htm
'-------------------------------------------------------------------------------
' Purpose : draw colored dials
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Draw_Dial.htm
'-------------------------------------------------------------------------------
' LICENSE
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Detail_Format
'-------------------------------------------------------------------------------
Private Sub Detail_Format(Cancel As Integer _
,FormatCount As Integer)
'draw dials
'CALLS
' Draw_Dial_s4p
Dim xCenter As Single _
,yCenter As Single _
,sgRadius As Single _
,sControlname As String _
,iValue As Integer
xCenter = 1 * TWIPperINCH
yCenter = 1 * TWIPperINCH
sgRadius = 0.75 * TWIPperINCH
With Me
'----------- Draw_Dial_s4p for fraction
Call Draw_Dial_s4p(Me,xCenter,yCenter,sgRadius _
,Me.Fractn.Value)
End With 'me
End Sub
'*************** Code End *******************************************************
Call from code behind report r_DIAL_Numberz_BackColor_Ratio
Send optional parameters for BackColor and ratio of inner circle
'*************** Code Start *****************************************************
' code behind report: r_Circle_DIAL
' Report Draw Reference:
' http://msaccessgurus.com/VBA/ReportDraw_Reference.htm
'-------------------------------------------------------------------------------
' Purpose : draw colored dials
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
'-------------------------------------------------------------------------------
' LICENSE
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Detail_Format
'-------------------------------------------------------------------------------
Private Sub Detail_Format(Cancel As Integer _
,FormatCount As Integer)
'draw dials
'CALLS
' Draw_Dial_s4p
Dim xCenter As Single _
,yCenter As Single _
,sgRadius As Single _
,sgRatio As Single _
,sControlname As String _
,iValue As Integer _
,nColorMiddle As Long
xCenter = 1 * TWIPperINCH
yCenter = 1 * TWIPperINCH
sgRadius = 0.75 * TWIPperINCH
sgRatio = 0.3
With Me
'set middle color to same as background
nColorMiddle = .Detail.BackColor 'assume no Alternate BackColor
'----------- Draw_Dial_s4p for fraction
Call Draw_Dial_s4p(Me,xCenter,yCenter,sgRadius _
,.Fractn.Value,nColorMiddle,sgRatio)
End With 'me
End Sub
'*************** Code End *******************************************************
Code was generated with colors using the free
Color Code add-in for Access
