Vba
Módulo estándar
'*************** Code Start *************************************************** ' Purpose : draw a Snowflake on an Access report ' specify center coordinate and radius ' optionally set snowflake and background colors ' USES Circle and Line ' 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. Mark your changes. Use at your own risk. '------------------------------------------------------------------------------ ' Global variables '------------------------------------------------------------------------------ Public Const PI As Double = 3.14159 Public Const gColorCyan As Long = 16769385 'RGB(105, 225, 255) '------------------------------------------------------------------------------ ' Draw_Snowflake_s4p ' send center coordinate and size '------------------------------------------------------------------------------ Public Sub Draw_Snowflake_s4p(poReport As Report _ ,pXCenter As Single _ ,pYCenter As Single _ ,ByVal pRadius As Single _ ,Optional pnColor1 As Long = gColorCyan _ ,Optional pnColor2 As Long = 0 _ ,Optional psgAngleStart As Single = 0 _ ) '221216 s4p 'Draw a Snowflake ' measurements in twips On Error GoTo Proc_Err 'PARAMETERs ' poReport is the Report object ' pXCenter is x-coordinate of snowflake center ' pYCenter is y-coordinate of snowflake center ' pRadius is snowflake radius '(Optional) ' pnColor1 = snowflake color ' Default is cyan ' pnColor2 = background color ' negative number is NO Background ' default is black circle background 'X and Y are for Line coordinates 'sgAngle is to calculate X and Y Dim X As Single,Y As Single _ ,x1 As Single,y1 As Single _ ,x2 As Single,y2 As Single _ ,sgAngle As Single _ ,sgAngleLeft As Single _ ,sgAngleRight As Single _ ,sgRadius1 As Single _ ,sgRadius2 As Single _ ,sgLength1 As Single _ ,sgLength2 As Single _ ,i As Integer 'adjust radius to account for draw width pRadius = pRadius * 0.93 '----------------------------- customize as desired sgRadius1 = pRadius / 3 sgRadius2 = 2 * pRadius / 3 sgLength1 = pRadius / 3 sgLength2 = pRadius / 3 sgAngleLeft = PI / 3 sgAngleRight = -PI / 3 '----------------------------- With poReport .ScaleMode = 1 'twips .DrawWidth = pRadius / 50 'relative based on size .FillStyle = 0 'Opaque If pnColor2 >= 0 Then 'draw circle background .FillColor = pnColor2 poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,pnColor2 End If 'draw needles sgAngle = psgAngleStart '6 sides For i = 0 To 5 X = pXCenter + Cos(sgAngle) * pRadius Y = pYCenter + Sin(sgAngle) * pRadius 'big needle .DrawWidth = pRadius / 50 poReport.Line (pXCenter,pYCenter)-(X,Y) _ ,pnColor1 'inner little needles. x1, y1 same for both lines x1 = pXCenter + Cos(sgAngle) * sgRadius1 y1 = pYCenter + Sin(sgAngle) * sgRadius1 'left needle x2 = x1 + Cos(sgAngle + sgAngleLeft) * sgLength1 y2 = y1 + Sin(sgAngle + sgAngleLeft) * sgLength1 .DrawWidth = pRadius / 150 poReport.Line (x1,y1)-(x2,y2),pnColor1 'right needle x2 = x1 + Cos(sgAngle + sgAngleRight) * sgLength1 y2 = y1 + Sin(sgAngle + sgAngleRight) * sgLength1 poReport.Line (x1,y1)-(x2,y2),pnColor1 'outer needles x1 = pXCenter + Cos(sgAngle) * sgRadius2 y1 = pYCenter + Sin(sgAngle) * sgRadius2 x2 = x1 + Cos(sgAngle + sgAngleLeft) * sgLength2 y2 = y1 + Sin(sgAngle + sgAngleLeft) * sgLength2 .DrawWidth = pRadius / 100 poReport.Line (x1,y1)-(x2,y2),pnColor1 x2 = x1 + Cos(sgAngle + sgAngleRight) * sgLength2 y2 = y1 + Sin(sgAngle + sgAngleRight) * sgLength2 poReport.Line (x1,y1)-(x2,y2),pnColor1 'next angle sgAngle = sgAngle - 2 * PI / 6 Next i End With Proc_Exit: On Error GoTo 0 Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " Draw_Snowflake_s4p" Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
Ir arriba
rpt_Copos de nieve_Colores
Informe de código subyacente para dibujar copos de nieve según los colores de estado.
'*************** Code Start Report1 *********************************************** ' Purpose : code behind rpt_Snowflakes_Colors ' calls Draw_Snowflake_s4p ' to draw Snowflakes based on status colors ' 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. Mark your changes. Use at your own risk. '------------------------------------------------------------------------------ ' Detail_Format '------------------------------------------------------------------------------ Private Sub Detail_Format(Cancel As Integer,FormatCount As Integer) '221216 crystal 'draw Snowflakes in the detail section of a report based on status colors 'CALLs ' Draw_Snowflake_s4p Dim X As Single,Y As Single _ ,sgRadius As Single 'left X = 0.5 * 1440 'top Y = 0.5 * 1440 'radius sgRadius = 0.5 * 1440 With Me 'Call Draw_Snowflake_s4p Call Draw_Snowflake_s4p(Me,X,Y,sgRadius _ ,Nz(.Colr1,0),Nz(.Colr2,-99)) End With End Sub '*************** Code End *****************************************************
Ir arriba
rpt_Copos de nieve_Página
¡Que nieve! Copos de nieve aleatorios por toda la página.
'*************** Code Start Report2 *********************************************** ' Purpose : code behind rpt_Snowflakes_Page ' calls Draw_Snowflake_s4p ' draw random Snowflakes all over the page ' different sizes and start angles ' 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. Mark your changes. Use at your own risk. '------------------------------------------------------------------------------ ' Report_Page '------------------------------------------------------------------------------ Private Sub Report_Page() '221216 crystal 'draw random Snowflakes all over the page 'CALLs ' Draw_Snowflake_s4p Dim X As Single,Y As Single _ ,x1 As Single,y1 As Single _ ,dx As Single,dy As Single _ ,sgAngle As Single _ ,sgRadius1 As Single _ ,sgRadius2 As Single _ ,sgRadius As Single _ ,iNumber As Integer _ ,iNumberSizes As Integer _ ,i As Integer _ ,j As Integer '---------------- customize Const NUMBERofSNOWFLAKES As Integer = 64 sgRadius1 = 360 sgRadius2 = 800 iNumberSizes = 4 '---------------- With Me .ScaleMode = 1 'twips 'width and height for drawing dx = .ScaleWidth dy = .ScaleHeight - .PageFooterSection.Height 'left X = .ScaleLeft 'top Y = .ScaleTop End With Randomize For i = 1 To iNumberSizes If i = 1 Then sgRadius = sgRadius1 ElseIf i = iNumberSizes Then sgRadius = sgRadius2 Else sgRadius = sgRadius1 + _ (sgRadius2 - sgRadius1) / (iNumberSizes - 2) * (i - 1) End If For j = 1 To NUMBERofSNOWFLAKES \ iNumberSizes 'get random coordinate x1 = (dx + 1) * Rnd + X y1 = (dy + 1) * Rnd + Y 'random start angle sgAngle = (2 * PI) * Rnd 'Call Draw_Snowflake_s4p -99 = no background Call Draw_Snowflake_s4p(Me,x1,y1,sgRadius _ ,,-99,sgAngle) Next j Next i End Sub '*************** Code End *****************************************************
Ir arriba
rpt_Snowflakes_Detail_Numberz
Informe de código subyacente para dibujar un número específico de copos de nieve en una fila en la sección de detalles. Hazlos lo más grandes posible.
'*************** Code Start Report3 *********************************************** ' Purpose : code behind rpt_Snowflakes_Detail_Numberz ' calls Draw_Snowflake_s4p ' draw specified number of snowflakes ' in the Detail section ' 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. Mark your changes. Use at your own risk. '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' Detail_Format '------------------------------------------------------------------------------ Private Sub Detail_Format(Cancel As Integer,FormatCount As Integer) '221216 crystal 'draw Snowflakes in the detail section of a report 'CALLs ' Draw_Snowflake_s4p 'USES ' global variables defined in bas_Draw_Snowflake_s4p ' gap between snowflake and edge Const sgPERCENTsize As Single = 0.9 Dim X As Single,Y As Single _ ,x1 As Single,y1 As Single _ ,dx As Single,dy As Single _ ,xMaxWidth As Single _ ,sgRadius As Single _ ,iNumber As Integer _ ,i As Integer With Me 'number of snowflakes to draw, bound to Numberz iNumber = .Num .ScaleMode = 1 'twips 'width and height for drawing dx = .ScaleWidth * sgPERCENTsize dy = .ScaleHeight * sgPERCENTsize 'left X = .ScaleLeft + (.ScaleWidth - dx) / 2 '+margin 'top Y = .ScaleTop + (.ScaleHeight - dy) / 2 'maximum width of each snowflake xMaxWidth = dx / iNumber 'which is less -- X or Y? If xMaxWidth > dy Then sgRadius = dy / 2 Else sgRadius = xMaxWidth / 2 End If End With y1 = Y + sgRadius 'put extra space below 'loop and Call Draw_Snowflake_s4p For i = 1 To iNumber x1 = X + xMaxWidth * (i - 0.5) Call Draw_Snowflake_s4p(Me,x1,y1,sgRadius) Next i End Sub '*************** Code End *****************************************************
‘ El código se generó con colores utilizando el complemento gratuito Color Code para Access.
