Vba
Módulo estándar
'*************** Code Start *************************************************** ' Purpose : draw the December Solstice on an Access report ' specify center coordinate and orbital radius ' optionally set colors for Earth, Sun, Rays, and lines ' USES Circle, Line, Print ' 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. ' bas_Draw_SolsticeDecember_s4p '------------------------------------------------------------------------------ ' Global variables '------------------------------------------------------------------------------ 'comment if defined elsewhere Public Const PI As Double = 3.14159 Public Const gColorYellowSun As Long = 7664895 'RGB(255, 244, 116) 'sun Public Const gColorOrangeRay As Long = 3333375 'RGB(255, 220, 50) Public Const gColorBlueEarth As Long = 16646420 'RGB(20, 1, 254) Public Const gColorGray As Long = 6579300 'RGB(100,100,100) '------------------------------------------------------------------------------ ' Draw_SolsticeDecember_s4p ' send report object, sun center coordinate and radius '------------------------------------------------------------------------------ Public Sub Draw_SolsticeDecember_s4p(poReport As Report _ ,pXCenter As Single _ ,pYCenter As Single _ ,pRadiusOrbit As Single _ ,Optional pnColrEarth As Variant = gColorBlueEarth _ ,Optional pnColrAxis As Variant = vbBlack _ ,Optional pnColrOrbit As Variant = gColorGray _ ,Optional pnColrSun As Variant = gColorYellowSun _ ,Optional gColorSunRay As Variant = gColorOrangeRay _ ) '221221 s4p 'Draw a Solstice ' measurements in twips On Error GoTo Proc_Err 'PARAMETERs ' poReport is the Report object ' pXCenter is x-coordinate of sun center ' pYCenter is y-coordinate of sun center ' pRadiusOrbit is orbit radius '(Optional) -- long integer color values ' defined as Variant so they can be null ' pnColrEarth ' pnColrAxis ' pnColrOrbit ' pnColrSun ' gColorSunRay If IsNull(pnColrEarth) Then pnColrEarth = gColorBlueEarth If IsNull(pnColrAxis) Then pnColrAxis = vbBlack If IsNull(pnColrOrbit) Then pnColrOrbit = gColorGray If IsNull(pnColrSun) Then pnColrSun = gColorYellowSun If IsNull(gColorSunRay) Then gColorSunRay = gColorOrangeRay 'variables Dim X As Single,Y As Single _ ,x1 As Single,y1 As Single _ ,x2 As Single,y2 As Single _ ,sgRadiusSun As Single _ ,sgRadiusEarth As Single _ ,sgRadiusAxis As Single _ ,sgAspectOrbit As Single _ ,sgAngleAxis As Single _ ,sgAngle As Single '----------------------------- customize as desired sgRadiusSun = pRadiusOrbit * 0.2 sgRadiusEarth = sgRadiusSun * 0.75 sgRadiusAxis = sgRadiusEarth * 1.4 sgAspectOrbit = 0.4 '----------------------------- sgAngleAxis = (90 + 23.4) / 180 * PI With poReport .ScaleMode = 1 'twips 'orbit .FillStyle = 1 'Transparent .DrawWidth = 4 'pixel poReport.Circle (pXCenter,pYCenter) _ ,pRadiusOrbit,pnColrOrbit,,,sgAspectOrbit .DrawWidth = 1 'pixel 'draw sun rays For sgAngle = 0 To 2 * PI Step PI / 12 x1 = pXCenter + Cos(sgAngle) * pRadiusOrbit * 1.2 y1 = pYCenter - Sin(sgAngle) * pRadiusOrbit * 1.2 poReport.Line (x1,y1)-(pXCenter,pYCenter),gColorOrangeRay Next sgAngle .FillStyle = 0 'Opaque 'sun .FillColor = pnColrSun poReport.Circle (pXCenter,pYCenter) _ ,sgRadiusSun,gColorSunRay 'earth center X = pXCenter - pRadiusOrbit 'axis .DrawWidth = 3 x1 = X + Cos(sgAngleAxis) * sgRadiusAxis y1 = pYCenter - Sin(sgAngleAxis) * sgRadiusAxis sgAngleAxis = sgAngleAxis + PI x2 = X + Cos(sgAngleAxis) * sgRadiusAxis y2 = pYCenter - Sin(sgAngleAxis) * sgRadiusAxis poReport.Line (x1,y1)-(x2,y2),pnColrAxis 'S for South .FontSize = 24 poReport.Print "S" 'N for North .CurrentX = x1 - .TextWidth( "N") .CurrentY = y1 - .TextHeight( "N") poReport.Print "N" 'earth .FillColor = pnColrEarth poReport.Circle (X,pYCenter) _ ,sgRadiusEarth,pnColrEarth 'equator sgAngleAxis = sgAngleAxis - PI / 2 x1 = X + Cos(sgAngleAxis) * sgRadiusEarth y1 = pYCenter - Sin(sgAngleAxis) * sgRadiusEarth x2 = X - Cos(sgAngleAxis) * sgRadiusEarth y2 = pYCenter + Sin(sgAngleAxis) * sgRadiusEarth poReport.Line (x1,y1)-(x2,y2),vbWhite End With Proc_Exit: On Error GoTo 0 Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " Draw_SolsticeDecember_s4p" Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
Ir arriba
rpt_SolsticioDiciembre
Informe de código subyacente para dibujar el solsticio de diciembre con la Tierra y el Sol. Aunque se pueden usar diferentes colores, no se especifican, por lo que verá los colores predeterminados.
'*************** Code Start CBR *********************************************** ' Purpose : code behind rpt_SolsticeDecember ' calls Draw_SolsticeDecember_s4p ' draw Winter Solstice on page (Landscape) ' 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() '221221 crystal 'draw Winter Solstice on a landscape page 'CALLs ' Draw_SolsticeDecember_s4p Dim X As Single,Y As Single _ ,sgRadius As Single _ ,dx As Single,dy As Single _ With Me .ScaleMode = 1 'twips 'width and height for drawing dx = .ScaleWidth dy = .ScaleHeight 'X center X = .ScaleLeft + dx / 2 'Y center Y = .ScaleTop + dy / 2 'radius based on X sgRadius = (dx / 2) * 0.85 End With 'Call Draw_SolsticeDecember_s4p Call Draw_SolsticeDecember_s4p(Me,X,Y,sgRadius) End Sub '*************** Code End *****************************************************
‘ El código se generó con colores utilizando el complemento gratuito Color Code para Access.
