VBA
Módulo estándar
Especifique el objeto del informe, un control para determinar los límites y un valor entre 1 y 3 para la luz (verde, amarilla, roja) que desea mostrar. Si no se envía el valor o este no es entre 1 y 3, se mostrarán círculos vacíos para las luces.
'*************** 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: '------------------------------------------------------------------------------- ' 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 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 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 *******************************************************
Llamada desde el informe de código subyacente
En lugar de utilizar datos reales, este código recorre los 3 valores (1=verde, 2=amarillo, 3=rojo)… pero espero que entiendas la idea.
'------------------------------------------------------------------------------- ' 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
El código se generó con colores utilizando el complemento gratuito Color Code para Access
