Dado que los colores se utilizan en cada registro, sus valores RGB de entero largo se definen en el evento ReportHeader_Format. Los círculos se dibujan (o no) en cada registro utilizando el evento Detail_Print.
Option Compare Database Option Explicit ' Draw Circles to show various methods to indicate True or False values '*************** Code Start ***************************************************** ' code behind report: r_CIRCLE_1_YesNo ' Report Draw Reference: ' ' VBA and download with this example: ' '------------------------------------------------------------------------------- ' Purpose : draw using the Circle method ' change center, radius, ' FillStyle, FillColor, and specified Color ' 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. '------------------------------------------------------------------------------- '------------------------------------------------------------------------------- ' Module variables for Color, define PI '------------------------------------------------------------------------------- Private mnColorRed As Long _ ,mnColorBlueMedium As Long _ ,mnColorYellow As Long _ ,mnColorBlack As Long _ ,mnColorGray As Long Private Const PI = 3.14159 'usually this would be global '------------------------------------------------------------------------------- ' ReportHeader_Format '------------------------------------------------------------------------------- Private Sub ReportHeader_Format(Cancel As Integer,FormatCount As Integer) 'define colors mnColorRed = RGB(255,0,0) mnColorBlueMedium = RGB(0,100,255) mnColorYellow = RGB(255,255,0) mnColorBlack = 0 mnColorGray = RGB(200,200,200) End Sub '------------------------------------------------------------------------------- ' Detail_Print '------------------------------------------------------------------------------- Private Sub Detail_Print(Cancel As Integer,PrintCount As Integer) 'draw circles on each record depending if the value is True or False '220628 strive4peace Dim iValue As Integer _ ,xCenter As Single _ ,yCenter As Single _ ,sgRadius As Single Dim xLeft As Single _ ,xWidth As Single _ ,yTop As Single _ ,yHeight As Single _ ,nColor As Long _ ,i As Integer ' iValue is ValueYesNo ' (xCenter, yCenter) is the circle center coordinate ' sgRadius is the circle radius ' use Label controls for boundaries With Me '----------- set up drawing space .ScaleMode = 1 'twips, default .DrawWidth = 1 'pixel 'it circle is filled, color it black 'get Value iValue = Nz(.ValueYesNo,0)
Ir arriba
| Verdadero = |  | Falso = | Nada |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ShowOrNot
'----------- Label_ShowOrNot
If iValue <> 0 Then
'if value is True then draw a circle
' in the middle of the
' Label_ShowOrNot control
With .Label_ShowOrNot
'--- radius of circle is limited by width or height
If .Width > .Height Then
sgRadius = .Height / 2
Else
sgRadius = .Width / 2
End If
'--- center coordinate for the circle
xCenter = .Left + .Width / 2
yCenter = .Top + .Height / 2
End With
'filled circle
.FillStyle = 0 'opaque
'fill color is blue
.FillColor = mnColorBlueMedium
'----- draw a circle
' middle is (xCenter, yCenter)
' radius is sgRadius
' outline color is blue
Me.Circle (xCenter,yCenter),sgRadius,mnColorBlueMedium
End If
Ir arriba
| Verdadero = |  | Falso = |  |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FilledOpen '----------- Label_FilledOpen With .Label_FilledOpen 'draw an open or closed circle in the middle of ' the Label_FilledOpen control '--- radius of circle is limited by width or height If .Width > .Height Then sgRadius = .Height / 2 Else sgRadius = .Width / 2 End If '--- center coordinate for the circle xCenter = .Left + .Width / 2 yCenter = .Top + .Height / 2 End With If iValue <> 0 Then 'if value is True then filled red circle .FillStyle = 0 'opaque .FillColor = mnColorRed Else 'if the value is False, then an open circle .FillStyle = 1 'transparent End If '----- draw a circle ' middle is (xCenter, yCenter) ' radius is sgRadius ' outline color is red Me.Circle (xCenter,yCenter),sgRadius,mnColorRed
Ir arriba
| Verdadero = |  | Falso = |  |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ OnOff ' height is split in 2 circles '----------- Label_FilledOpen With .Label_OnOff '--- radius of circle is limited by width or half height If .Width > .Height / 2 Then sgRadius = .Height / 4 Else sgRadius = .Width / 2 End If 'horizontal center is the same for both xCenter = .Left + .Width / 2 'yCenter will be calculated yTop = .Top yHeight = .Height End With .FillStyle = 0 'opaque '----- Top and Bottom Circles For i = 0 To 1 'Top then bottom 'Circle vertical center yCenter = yTop + yHeight / 4 _ + i * sgRadius * 2 'top circle is ON 'bottom circle is OFF If iValue <> 0 And i = 0 Then 'True is filled black circle nColor = mnColorBlack Else nColor = mnColorGray End If '----- draw a circle ' middle is (xCenter, yCenter) ' radius is sgRadius ' outline color is nColor .FillColor = nColor Me.Circle (xCenter,yCenter),sgRadius,nColor Next i
Ir arriba
| Verdadero = |  | Falso = |  |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Switch ' width is split in 2 circles '----------- Label_Switch With .Label_Switch '--- radius of circle is limited by height or half width If .Width / 2 > .Height Then sgRadius = .Height / 2 Else sgRadius = .Width / 4 End If 'vertical center is the same for both yCenter = .Top + .Height / 2 'xCenter will be calculated xLeft = .Left xWidth = .Width End With '----- Left and Right Circles For i = 0 To 1 'Left then right 'Circle horizontal center xCenter = xLeft + xWidth / 4 _ + i * sgRadius * 2 'left circle is OFF 'right circle is ON 'if drawing left circle, color is gray 'if drawing right circle, color is black If i = 0 Then nColor = mnColorGray Else nColor = mnColorBlack End If ' if value is false and on left then fill ' if value is true and on right, fill If iValue = 0 And i = 0 _ Or iValue <> 0 And i = 1 _ Then .FillStyle = 0 'opaque Else .FillStyle = 1 'transparent End If '----- draw a circle ' middle is (xCenter, yCenter) ' radius is sgRadius ' outline color is nColor .FillColor = nColor Me.Circle (xCenter,yCenter),sgRadius,nColor Next i
Ir arriba
| Verdadero = |  | Falso = |  |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ TopBottom '----------- Label_TopBottom With .Label_TopBottom '--- radius of circle is limited by height or width If .Width > .Height Then sgRadius = .Height / 2 Else sgRadius = .Width / 2 End If 'center is the same for both xCenter = .Left + .Width / 2 yCenter = .Top + .Height / 2 End With .FillStyle = 0 'opaque 'if filled, it will be yellow .FillColor = mnColorYellow '----- Top and Bottom Half Filled Circles '----- draw a circle ' middle is (xCenter, yCenter) ' radius is sgRadius ' outline color is Blue If iValue <> 0 Then 'top half is True ' angle is 0 to PI ' negative indicates fill, the angle is positive ' instead of 0, use very small number Me.Circle (xCenter,yCenter),sgRadius,mnColorBlueMedium _ ,-0.000000001,-PI Else 'bottom half is False ' angle is PI to 2*PI Me.Circle (xCenter,yCenter),sgRadius,mnColorBlueMedium _ ,PI,2 * PI End If
Ir arriba
| Verdadero = |  | Falso = |  |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ LeftRight '----------- Label_LeftRight With .Label_LeftRight '--- radius of circle is limited by height or width If .Width > .Height Then sgRadius = .Height / 2 Else sgRadius = .Width / 2 End If 'center is the same for both xCenter = .Left + .Width / 2 yCenter = .Top + .Height / 2 End With .FillStyle = 0 'opaque .FillColor = mnColorBlack '----- Left and Right Half Filled Circles '----- draw a circle ' middle is (xCenter, yCenter) ' radius is sgRadius ' outline color is Blue ' angle is negative to indicate fill If iValue <> 0 Then 'right is true 'angle2 has to be >= angle1 'and circle can't go past 360° or 2 Pi radians 'so it is drawn in 2 parts Me.Circle (xCenter,yCenter),sgRadius,mnColorBlack _ ,-0.0000001,-PI / 2 Me.Circle (xCenter,yCenter),sgRadius,mnColorBlack _ ,-3 / 2 * PI,-2 * PI Else 'left is false Me.Circle (xCenter,yCenter),sgRadius,mnColorBlack _ ,-PI / 2,-3 / 2 * PI End If ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ End With 'Me End Sub '*************** Code End *******************************************************
