VBA
Módulo estándar
Especifique el objeto del informe, las coordenadas XY del centro del dial, el radio, el valor (fracción o porcentaje) y, opcionalmente, un color para el centro y la relación entre el centro y el tamaño total. Las medidas lineales se expresan en twips (veinte en un punto).
'*************** Code Start ***************************************************** ' module: mod_Draw_Dial_s4p '------------------------------------------------------------------------------- ' Purpose : Draw a Dial on an Access report ' Author : crystal (strive4peace) ' License : below code ' Code List: msaccessgurus.com/code.htm ' This code: '------------------------------------------------------------------------------- ' global variables '------------------------------------------------------------------------------- 'comment if defined elsewhere Public ganColorRedOrangeYellowGreen30(1 To 30) As Long Public Const TWIPperINCH As Long = 1440 Public Const PI As Double = 3.14159 Public Const gZero As Double = 0.0000001 '------------------------------------------------------------------------------- ' Draw_Dial_s4p '------------------------------------------------------------------------------- Sub Draw_Dial_s4p(oReport As Report _ ,pXCenter As Single,pYCenter As Single _ ,pRadius As Single _ ,Optional psgValue As Variant = -1 _ ,Optional pnColorCenter As Long = vbWhite _ ,Optional psgRatio As Single = 0.6 _ ) '220617 strive4peace, 230414 'draw a dial with 30 colors from Red to Orange to Yellow to Green 'dial starts in SW quadrant 'PARAMETERS ' oReport is the Report object ' pXCenter is the center of dial in twips for the x-coordinate ' pYCenter is the center of dial in twips for the y-coordinate ' pRadius is the circle radius in twips 'OPTIONAL PARAMETERS ' psgValue is a percent % or fraction -- ' defined as variant so it can be null ' pnColorCenter is the long integer color number for the middle ' psgRatio = ratio of inside circle to circle If psgValue > 1 Then 'value can't be greater than 100% psgValue = 1 ElseIf IsNull(psgValue) Then psgValue = -1 'don't show needle End If Dim sgRadiusInside As Single _ ,sgRadiusNeedle As Single _ ,x1 As Single,y1 As Single _ ,x2 As Single,y2 As Single _ ,sgAngle As Single _ ,sgAngle1 As Single _ ,sgAngle2 As Single _ ,sgStartAngle As Single _ ,sgWedgeAngle As Single _ ,sgTickAngle As Single _ ,i As Integer _ ,iQty As Integer _ ,nColorNeedle As Long Dim iGapDegree As Integer _ ,sgGapAngle As Single If ganColorRedOrangeYellowGreen30(1) = 0 Then 'set colors if not yet defined Call SetColors_RedOrangeYellowGreen30 End If iQty = 30 'number of wedges - depends on number of colors sgTickAngle = 1 / 180 * PI 'spacing between wedges for tick marks iGapDegree = 60 'gap at bottom sgGapAngle = iGapDegree / 180 * PI sgWedgeAngle = ((PI * 2) - sgGapAngle) / iQty sgStartAngle = 1.5 * PI - sgGapAngle / 2 '270° - half gap nColorNeedle = RGB(0,0,255) 'blue 16711680 With oReport .ScaleMode = 1 'twips .DrawWidth = 1 'pixel .FillStyle = 0 'Opaque sgAngle2 = sgStartAngle 'draw colored wedges for the dial For i = 1 To 30 sgAngle1 = sgAngle2 - sgWedgeAngle 'do this so it can be negative If sgAngle1 = 0 Then sgAngle1 = gZero End If 'Circle angle: 0 to 2 pi ' starts at sgStartAngle and goes backward ' to be clockwise .FillColor = ganColorRedOrangeYellowGreen30(i) oReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,ganColorRedOrangeYellowGreen30(i) _ ,-(sgAngle1 + sgTickAngle) _ ,-(sgAngle2 - sgTickAngle) If sgAngle1 Then sgAngle2 = 2 * PI - gZero Else sgAngle2 = sgAngle1 End If Next i 'draw center circle in the middle .FillColor = pnColorCenter sgRadiusInside = psgRatio * pRadius oReport.Circle (pXCenter,pYCenter) _ ,sgRadiusInside _ ,pnColorCenter 'draw needle If psgValue >= 0 Then 'round end sgRadiusNeedle = pRadius * 0.15 'find the angle for the value sgAngle = sgStartAngle - _ (((2 * PI) - sgGapAngle) _ * psgValue) If sgAngle Then sgAngle = sgAngle + (2 * PI) End If x1 = pXCenter + Cos(sgAngle) _ * (sgRadiusInside - sgRadiusNeedle * 1.5) y1 = pYCenter - Sin(sgAngle) _ * (sgRadiusInside - sgRadiusNeedle * 1.5) 'draw circle .FillColor = nColorNeedle sgRadiusInside = psgRatio * pRadius oReport.Circle (x1,y1) _ ,sgRadiusNeedle _ ,nColorNeedle 'outside coordinate for needle x2 = pXCenter + Cos(sgAngle) _ * pRadius y2 = pYCenter - Sin(sgAngle) _ * pRadius 'draw blue line for needle .DrawWidth = 10 oReport.Line (x1,y1)-(x2,y2),nColorNeedle End If 'needle End With Proc_Exit: On Error GoTo 0 Exit Sub Proc_Err: MsgBox Err.Description,,_ "ERROR " & Err.Number _ & " Draw_Dial_s4p " Resume Proc_Exit Resume End Sub '------------------------------------------------------------------------------- ' SetColors_RedOrangeYellowGreen30 '------------------------------------------------------------------------------- Public Sub SetColors_RedOrangeYellowGreen30() ganColorRedOrangeYellowGreen30(1) = 2763685 'RGB: 165, 43, 42 ganColorRedOrangeYellowGreen30(2) = 2105532 'RGB: 188, 32, 32 ganColorRedOrangeYellowGreen30(3) = 1382098 'RGB: 210, 22, 21 ganColorRedOrangeYellowGreen30(4) = 658408 'RGB: 232, 11, 10 ganColorRedOrangeYellowGreen30(5) = 255 'RGB: 255, 0, 0 ganColorRedOrangeYellowGreen30(6) = 10751 'RGB: 255, 41, 0 ganColorRedOrangeYellowGreen30(7) = 21247 'RGB: 255, 82, 0 ganColorRedOrangeYellowGreen30(8) = 31999 'RGB: 255, 124, 0 ganColorRedOrangeYellowGreen30(9) = 42495 'RGB: 255, 165, 0 ganColorRedOrangeYellowGreen30(10) = 42495 'RGB: 255, 176, 0 ganColorRedOrangeYellowGreen30(11) = 48383 'RGB: 255, 188, 0 ganColorRedOrangeYellowGreen30(12) = 54015 'RGB: 255, 210, 0 ganColorRedOrangeYellowGreen30(13) = 59647 'RGB: 255, 232, 0 ganColorRedOrangeYellowGreen30(14) = 65535 'RGB: 255, 244, 0 ganColorRedOrangeYellowGreen30(15) = 65535 'RGB: 255, 255, 0 ganColorRedOrangeYellowGreen30(16) = 1375480 'RGB: 248, 252, 20 ganColorRedOrangeYellowGreen30(17) = 2685680 'RGB: 240, 250, 40 ganColorRedOrangeYellowGreen30(18) = 4061417 'RGB: 233, 248, 61 ganColorRedOrangeYellowGreen30(19) = 5371362 'RGB: 226, 246, 71 ganColorRedOrangeYellowGreen30(20) = 5371362 'RGB: 226, 245, 81 ganColorRedOrangeYellowGreen30(21) = 4841658 'RGB: 186, 224, 73 ganColorRedOrangeYellowGreen30(22) = 4312210 'RGB: 146, 204, 65 ganColorRedOrangeYellowGreen30(23) = 3782761 'RGB: 105, 184, 57 ganColorRedOrangeYellowGreen30(24) = 3253057 'RGB: 65, 163, 49 ganColorRedOrangeYellowGreen30(25) = 3253057 'RGB: 65, 150, 45 ganColorRedOrangeYellowGreen30(26) = 2722362 'RGB: 58, 138, 41 ganColorRedOrangeYellowGreen30(27) = 2191923 'RGB: 51, 114, 33 ganColorRedOrangeYellowGreen30(28) = 1661484 'RGB: 44, 102, 28 ganColorRedOrangeYellowGreen30(29) = 1130789 'RGB: 37, 84, 21 ganColorRedOrangeYellowGreen30(30) = 1130789 'RGB: 37, 65, 17 End Sub '*************** Code End *******************************************************
Llamada desde el código subyacente del informe r_DIAL_Numberz
Utiliza una tabla con números (Numberz) para obtener valores para este ejemplo
'*************** Code Start ***************************************************** ' code behind report: r_DIAL_Numberz ' Report Draw Reference: ' '------------------------------------------------------------------------------- ' Purpose : draw colored dials ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: '------------------------------------------------------------------------------- ' LICENSE ' You may freely use and share this code, but not sell it. ' Keep attribution. Use at your own risk. '------------------------------------------------------------------------------- '------------------------------------------------------------------------------- ' Detail_Format '------------------------------------------------------------------------------- Private Sub Detail_Format(Cancel As Integer _ ,FormatCount As Integer) 'draw dials 'CALLS ' Draw_Dial_s4p Dim xCenter As Single _ ,yCenter As Single _ ,sgRadius As Single _ ,sControlname As String _ ,iValue As Integer xCenter = 1 * TWIPperINCH yCenter = 1 * TWIPperINCH sgRadius = 0.75 * TWIPperINCH With Me '----------- Draw_Dial_s4p for fraction Call Draw_Dial_s4p(Me,xCenter,yCenter,sgRadius _ ,Me.Fractn.Value) End With 'me End Sub '*************** Code End *******************************************************
Llamada desde el código subyacente del informe r_DIAL_Numberz_BackColor_Ratio
Envíe parámetros opcionales para BackColor y la relación del círculo interior
'*************** Code Start ***************************************************** ' code behind report: r_Circle_DIAL ' Report Draw Reference: ' '------------------------------------------------------------------------------- ' Purpose : draw colored dials ' 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. '------------------------------------------------------------------------------- '------------------------------------------------------------------------------- ' Detail_Format '------------------------------------------------------------------------------- Private Sub Detail_Format(Cancel As Integer _ ,FormatCount As Integer) 'draw dials 'CALLS ' Draw_Dial_s4p Dim xCenter As Single _ ,yCenter As Single _ ,sgRadius As Single _ ,sgRatio As Single _ ,sControlname As String _ ,iValue As Integer _ ,nColorMiddle As Long xCenter = 1 * TWIPperINCH yCenter = 1 * TWIPperINCH sgRadius = 0.75 * TWIPperINCH sgRatio = 0.3 With Me 'set middle color to same as background nColorMiddle = .Detail.BackColor 'assume no Alternate BackColor '----------- Draw_Dial_s4p for fraction Call Draw_Dial_s4p(Me,xCenter,yCenter,sgRadius _ ,.Fractn.Value,nColorMiddle,sgRatio) End With 'me End Sub '*************** Code End *******************************************************
El código se generó con colores utilizando el complemento gratuito Color Code para Access
