VBA
Standard module
Specify report object,
a control to determine boundaries,
and a value from 1 to 3 for which light (green, yellow, red)
that you want to show.
If value isn't sent,or value isn't 1-3, empty circles for the lights will show.
'*************** Code Start *****************************************************
' module: mod_Draw_Stoplight_s4p
'-------------------------------------------------------------------------------
' Purpose : Draw a Stoplight on an Access report
' draw within the boundaries of a control that you specify (can be a Label)
' value: 1=green, 2=yellow, 3=red
' Author : crystal (strive4peace)
' License : below code
' Code List: msaccessgurus.com/code.htm
' This code: http://msaccessgurus.com/VBA/Code/DrawStoplight.htm
'-------------------------------------------------------------------------------
' public variables
'-------------------------------------------------------------------------------
'comment if set elsewhere
Public gXCenter As Single,gYCenter As Single _
,gRadius As Single
Public gXLeft As Single,gYTop As Single _
,gXWidth As Single,gYHeight As Single
Public gvValue As Variant
Public Const PI As Double = 3.14159
'-------------------------------------------------------------------------------
' Draw_Stoplight_s4p
'-------------------------------------------------------------------------------
Sub Draw_Stoplight_s4p(oReport As Report _
,oControl As Control _
,Optional piValue As Integer _
)
'piValue: 1=green, 2=yellow, 3=red
'CALLs
' ReadScale
' SetCenter
' Draw_RectangleRounded
Dim x1 As Single,y1 As Single _
,x2 As Single,y2 As Single _
,yEndHeight As Single _
,sgMargin As Single _
,sgRatioLight As Single _
,iDrawWidth As Integer _
,nColor As Long
Dim nColorGreen As Long _
,nColorYellow As Long _
,nColorRed As Long _
,nColorOff As Long _
,nColorBorder As Long _
On Error GoTo Proc_Err
'get boundaries
Call ReadScale(oControl,False)
'------------------------ height of each end cap and roof
yEndHeight = gYHeight / 20
'adjust top and bottom cap+roof on top
' and cap on bottom
gYTop = gYTop + 2 * yEndHeight
gYHeight = gYHeight - 3 * yEndHeight
Call SetCenter(1,3) 'set gXCenter, gYCenter, gRadius
'------------------------ percent for light radius
sgRatioLight = 0.8
nColorGreen = RGB(0,255,0)
nColorYellow = RGB(255,255,0)
nColorRed = RGB(255,0,0)
nColorOff = RGB(242,242,242)
nColorBorder = 0
sgMargin = 12
If gXWidth < (gYHeight / 3) Then
'center horizontally
' gRadius = gXWidth / 2 - sgMargin
x1 = gXLeft
x2 = gXLeft + gXWidth
'move it down for the top stuff
y1 = gYCenter - 3 * gRadius
y2 = gYCenter + 3 * gRadius
Else
'center vertically
' gRadius = gYHeight / 6 - * sgMargin
x1 = gXCenter - gRadius
x2 = gXCenter + gRadius
y1 = gYTop
y2 = gYTop + gYHeight
End If
With oReport
.ScaleMode = 1 'twips
'--- draw top
.DrawWidth = 1
'gray dome on top and bottom
.FillStyle = 0 'Opaque
' .FillColor = RGB(200, 200, 200)
'-- top
oReport.Line (gXCenter - gRadius * 0.5 _
,gYTop - 2 * yEndHeight _
)-(gXCenter + gRadius * 0.5 _
,gYTop - yEndHeight) _
,RGB(100,100,100) _
,BF
'-- bottom
oReport.Line (gXCenter - gRadius * 0.5 _
,gYTop + gYHeight _
)-(gXCenter + gRadius * 0.5 _
,gYTop + gYHeight + yEndHeight) _
,RGB(100,100,100) _
,BF
'--- black roof
' .FillColor = 0
oReport.Line (gXCenter - gRadius * 0.9 _
,gYTop - yEndHeight _
)-(gXCenter + gRadius * 0.9 _
,gYTop - yEndHeight * 0.5) _
,0 _
,BF
oReport.Line (gXCenter - gRadius * 1.4 _
,gYTop - yEndHeight * 0.5 _
)-(gXCenter + gRadius * 1.4 _
,gYTop) _
,0 _
,BF
'--- draw frame
iDrawWidth = 5 'pixel
.DrawWidth = iDrawWidth
'gray filled box behind
.FillStyle = 0 'Opaque
.FillColor = RGB(200,200,200)
oReport.Line (x1,y1)-(x2,y2) _
,RGB(200,200,200) _
,B
'Black border box
.FillStyle = 1 'Transparent
oReport.Line (x1,y1)-(x2,y2),0,B
'Draw_RectangleRounded
x1 = x1 + iDrawWidth * 2
x2 = x2 - iDrawWidth * 3
y1 = y1 + iDrawWidth '* 1.5
y2 = y2 - iDrawWidth * 3
'DrawWidth=3
Call Draw_RectangleRounded(oReport _
,x1,y1,x2,y2 _
,3,RGB(150,150,150))
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ lights
y1 = gYCenter + 2 * gRadius - sgMargin 'bottom - green
y2 = gYCenter - 2 * gRadius + sgMargin 'top - red
.FillStyle = 0 'Opaque
.DrawWidth = 1
'--- GREEN, bottom
If piValue = 1 Then
nColor = nColorGreen
Else
nColor = nColorOff
End If
.FillColor = nColor
oReport.Circle (gXCenter,y1) _
,gRadius * sgRatioLight _
,nColorBorder
'--- YELLOW, middle
If piValue = 2 Then
nColor = nColorYellow
Else
nColor = nColorOff
End If
.FillColor = nColor
oReport.Circle (gXCenter,gYCenter) _
,gRadius * sgRatioLight _
,nColorBorder
'--- RED, top
If piValue = 3 Then
nColor = nColorRed
Else
nColor = nColorOff
End If
.FillColor = nColor
oReport.Circle (gXCenter,y2) _
,gRadius * sgRatioLight _
,nColorBorder
End With
Proc_Exit:
On Error Resume Next
Exit Sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " Draw_Stoplight_s4p"
Resume Proc_Exit
Resume
End Sub
'-------------------------------------------------------------------------------
' ReadScale
'-------------------------------------------------------------------------------
Public Sub ReadScale(oControl As Control _
,Optional pbGetValue As Boolean = False)
'220618 s4p
'read control Scale, set global variables
'first step
With oControl
gXLeft = .Left
gYTop = .Top
gXWidth = .Width
gYHeight = .Height
gvValue = Null
If pbGetValue <> False Then
If Not IsNull(.Value) Then
gvValue = .Value
End If
End If
End With
End Sub
'-------------------------------------------------------------------------------
' SetCenter
'-------------------------------------------------------------------------------
Public Sub SetCenter( _
Optional piQtyX As Integer = 1 _
,Optional piQtyY As Integer = 1 _
)
'220618 strive4peace
'calculate gXCenter, gYCenter, gRadius
' from global variables
'optionally, send number of objects if not 1
' such as Stoplight has piQtyY=3
gXCenter = gXLeft + gXWidth / 2
gYCenter = gYTop + gYHeight / 2
If gXWidth / piQtyX < gYHeight / piQtyY Then
gRadius = gXWidth / piQtyX / 2
Else
gRadius = gYHeight / piQtyY / 2
End If
End Sub
'-------------------------------------------------------------------------------
' Draw_RectangleRounded
'-------------------------------------------------------------------------------
Sub Draw_RectangleRounded(oReport As Report _
,xLeft As Single _
,yTop As Single _
,xRight As Single _
,yBottom As Single _
,Optional piDrawWidth As Integer = 1 _
,Optional pnColor As Long = 9868950 _
,Optional psgRadiusCorner As Single = 80 _
)
'use Line to draw lines
'Circle to draw arcs for corners
'9868950=rgb(150,150,150)
Dim x1 As Single,y1 As Single _
,x2 As Single,y2 As Single
x1 = xLeft
x2 = xRight
y1 = yTop + psgRadiusCorner
y2 = yBottom - psgRadiusCorner
oReport.DrawWidth = piDrawWidth
'--- sides
'left side
oReport.Line (x1,y1)-(x1,y2),pnColor
'right side
oReport.Line (x2,y1)-(x2,y2),pnColor
x1 = xLeft + psgRadiusCorner
x2 = xRight - psgRadiusCorner
y1 = yTop
y2 = yBottom
'top
oReport.Line (x1,y1)-(x2,y1),pnColor
'bottom
oReport.Line (x1,y2)-(x2,y2),pnColor
'--- corners
x1 = xLeft + psgRadiusCorner
y1 = yTop + psgRadiusCorner
'--------------------------------- 'todo: test for big dimensions
'adjust centers for line width
x2 = xRight - psgRadiusCorner _
+ piDrawWidth * 2
y2 = yBottom - psgRadiusCorner _
+ piDrawWidth * 2
'top left corner
oReport.Circle (x1,y1),psgRadiusCorner _
,pnColor,PI / 2,PI
'top right corner
oReport.Circle (x2,y1),psgRadiusCorner _
,pnColor,0,PI / 2
'bottom left corner
oReport.Circle (x1,y2 + piDrawWidth),psgRadiusCorner _
,pnColor,PI,3 / 2 * PI
'bottom right corner
oReport.Circle (x2,y2),psgRadiusCorner _
,pnColor,3 / 2 * PI,2 * PI
End Sub
'*************** Code End *******************************************************
Call from code behind report
Instead of using actual data,
this code loops though the 3 values
(1=green, 2=yellow, 3=red) ...
but hopefully you get the gist
'-------------------------------------------------------------------------------
' Detail_Format
'-------------------------------------------------------------------------------
Private Sub Detail_Format(Cancel As Integer,FormatCount As Integer)
'230408
Dim i As Integer _
,sControlname As String _
,iValue As Integer
For i = 1 To 3
sControlname = "Label" & i
iValue = i
' Call Draw_Stoplight_s4p(Me, Me(sControlname), iValue)
Call Draw_Stoplight_s4p(Me,Me(sControlname),iValue)
Next i
End Sub
Code was generated with colors using the free
Color Code add-in for Access
