|
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.
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
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
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 *******************************************************
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 SubCode was generated with colors using the free Color Code add-in for Access
Report Draw Reference for VBA syntax and help for drawing on Access reports.
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.
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
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
~ crystal
the simplest way is best, but usually the hardest to see