Stoplight drawn by Access on an Access report Ms Access Gurus

Hoping stoplights are green for you! Donations are a great way to say thank you and help bring you new content.

Draw a Stoplight in Access

Draw Stoplights showing showing whatever color you want emphasized on your Access reports ... Green, Yellow, Red. VBA procedure that's easy to call from code behind your reports. VBA procedure that's easy to call from code behind your reports. Access can draw complex objects using a few simple methods.

Send the report object, any control to get position and maximum height/width (labels okay), and value (1=green, 2=yellow, 3=red) so Access can draw a Stoplight displaying the color (if any) that you desire, and where you want it to be.

The code that does the drawing is all in one module that you can easily import into your projects. Although the drawing is complex, it only uses the Circle and Line methods. The VBA code is open so you can learn how it's done.

DevCon
April 27 + 28 (Thursday + Friday), 2023

Do you want to participate in a presentation about drawing on Access reports? Come to Access DevCon, a huge annual Access conference open to the world, organized by Karl Donaubauer with help from Peter Doering and Philipp Stiefel. Here are the speakers: Access DevCon Agenda.

Join me, Access experts, and developers who love Access. I'm presenting Draw Gadgets on Access Reports and would be happy to see you. It's virtual, so you can join from anywhere! Register for DevCon

Show a Stoplight on an Access report

Quick Jump

Goto Top  


Download

Download zipped BAS file you can import into your Access projects: mod_Draw_Stoplight_s4p.zip

Download zipped ACCDB file with a sample sample report, and module: DrawStopLight__ACCDB.zip

Remember to UNBLOCK files you download to remove the Mark of the Web. Here are steps to do that: https://msaccessgurus.com/MOTW_Unblock.htm

Goto Top  

Try it yourself

There is one sample report. Read comments to see how to use your data.

Goto Top  

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

Goto Top  

Reference

Drawing Reference on MsAccessGurus

Report Draw Reference for VBA syntax and help for drawing on Access reports.

Circle method

Line method

DrawWidth property

FillColor property

FillStyle property

ScaleMode property

Goto Top  

Backstory

Stoplights are easy to recognize. Using graphics to indicate values makes them easier to see ... a picture is worth a thousand words

Report Draw Reference and VBA Syntax VBA drawing code with links to more pages with code to draw on your Access reports. If you can imagine it, Access can do it!

If you find this page useful, let me know. Donations are much appreciated, large and small.

Share with others

Here's the link for this page in case you want to copy it and share it with someone:

https://msaccessgurus.com/VBA/Draw_Stoplight.htm

or in old browsers:
http://www.msaccessgurus.com/VBA/Draw_Stoplight.htm

Get Tutoring with Access and drawing

Let's connect and team-develop your application together. I teach you how to do it yourself. My goal is to empower you.

While we build something great together, I'll pull in code and features from my vast libraries as needed, cutting out lots of development time. I'll give you lots of links to good resources.

Do you want your reports to be more creative and visual? I'd love to help you. Email me at training@msAccessGurus.com

~ crystal

the simplest way is best, but usually the hardest to see

Goto Top