VBA
Módulo estándar
Especifique el objeto del informe, la ubicación y el tamaño y, opcionalmente, la fracción de luz, creciente o menguante y los colores.
' module name: bas_Draw_Moon_s4p '*************** Code Start *************************************************** ' Purpose : draw the Moon on an Access report in any phase ' specify report object, center coordinate and radius ' optionally set colors, fraction lit, ' and if moon is waxing or waning ' USES Circle ' 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 gZero As Double = 0.0000001 Public Const TWIPperINCH As Long = 1440 Public Const gColorGrayVeryLight As Long = 16448250 'RGB(250, 250, 250) Public Const gColorGray As Long = 11513775 'RGB(200, 200, 200) Public Const gColorMidnightBlue As Long = 7346457 'RGB(25, 25, 112) Public Const gColorPaleYellow As Long = 9298389 'RGB(213, 225, 141) Public Const gColorCyan As Long = 16769385 'RGB(105, 225, 255) '------------------------------------------------------------------------------ ' Draw_Moon_s4p ' send center coordinate and size '------------------------------------------------------------------------------ Public Sub Draw_Moon_s4p(poReport As Report _ ,pXCenter As Double _ ,pYCenter As Double _ ,ByVal pRadius As Double _ ,Optional pFractionLit As Single = 1 _ ,Optional pbWax As Boolean _ ,Optional pnColorLight As Long = vbWhite _ ,Optional pnColorDark As Long = vbBlack _ ,Optional pnColorOutline As Long = gColorGray _ ) '230209, 11 On Error GoTo Proc_Err 'PARAMETERs ' poReport = report object ' pXCenter, pYCenter = center of moon ' pRadius = radius of moon ' pFractionLit = fraction that is lit, 0 to 1 ' pbWax = True if waxing (light on right) ' False if waning (light on left) ' pnColorLight = color for the lit part of moon ' pnColorDark = color for the dark part of moon ' pnColorOutline = outline color, negative is no outline Dim nLeftColor As Long _ ,nRightColor As Long _ ,nMiddleColor As Long _ ,dbAngle1 As Double _ ,dbAngle2 As Double _ ,sgAspect As Single If pbWax = True Then 'light on the right nRightColor = pnColorLight nLeftColor = pnColorDark Else nRightColor = pnColorDark nLeftColor = pnColorLight End If If Abs(pFractionLit - 0.5) Then 'no middle oval ElseIf pFractionLit > 0.5 Then nMiddleColor = pnColorLight sgAspect = 1 / ((pFractionLit - 0.5) * 2) Else nMiddleColor = pnColorDark sgAspect = 1 / ((0.5 - pFractionLit) * 2) End If With poReport .ScaleMode = 1 'twips .DrawWidth = 1 'iDrawWidth .FillStyle = 0 'Opaque If pFractionLit > 0.99999 Then 'full mooon .FillColor = pnColorLight poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,pnColorLight ElseIf Abs(pFractionLit) Then 'new moon .FillColor = pnColorDark poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,pnColorDark Else 'draw a filled half circle on the right dbAngle1 = gZero dbAngle2 = PI / 2 .FillColor = nRightColor poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,nRightColor _ ,-dbAngle1,-dbAngle2 dbAngle1 = PI * 3 / 2 dbAngle2 = PI poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,nRightColor _ ,-dbAngle1,-dbAngle2 'draw a filled half circle on the left dbAngle1 = PI / 2 dbAngle2 = PI * 3 / 2 .FillColor = nLeftColor poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,nLeftColor _ ,-dbAngle1,-dbAngle2 'draw middle oval If Abs(pFractionLit - 0.5) > 0.001 Then 'draw oval to cover middle .FillColor = nMiddleColor poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,nMiddleColor _ ,,,sgAspect End If End If 'draw outline If pnColorOutline >= 0 Then .FillStyle = 1 'transparent poReport.Circle (pXCenter,pYCenter) _ ,pRadius _ ,pnColorOutline End If End With 'poReport Proc_Exit: On Error GoTo 0 Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " Draw_Moon_s4p" Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
Ir al inicio
rpt_Fases lunares_fila amarilla y azul
Código que sustenta el informe para dibujar las ocho fases de la luna. El movimiento va de derecha a izquierda. El código abre un conjunto de registros en una tabla con datos lunares.
'*************** Code Start CBR *********************************************** ' Purpose : code behind rpt_MoonPhases_YellowBlue_row ' calls Draw_Moon_s4p ' draw 8 phases of the moon ' from right to left since movement is counter-clockwise ' opens recordset to table with moon data ' 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. '------------------------------------------------------------------------------ ' module variables '------------------------------------------------------------------------------ Private mWidthMoon As Double _ ,mRadiusMoon As Double Private Const MOONsPerLine As Integer = 8 'change as desired '------------------------------------------------------------------------------ ' PageHeaderSection_Format '------------------------------------------------------------------------------ Private Sub PageHeaderSection_Format(Cancel As Integer,FormatCount As Integer) '230214 strive4peace 'calculate size of moons, maybe 8 on each line With Me .ScaleMode = 1 'twips '--- width and radius of each moon '1/2 moon spacing '1/4 moon left and right margin mWidthMoon = .ScaleWidth / _ (MOONsPerLine + (MOONsPerLine + 1) / 4) 'moon radius mRadiusMoon = mWidthMoon / 2 End With End Sub '------------------------------------------------------------------------------ ' Detail_Format '------------------------------------------------------------------------------ Private Sub Detail_Format(Cancel As Integer,FormatCount As Integer) '230212 s4p On Error GoTo Proc_Err Dim db As DAO.Database _ ,rs As DAO.Recordset Dim sSQL As String _ ,iMoon As Integer _ ,iLine As Integer Dim xCenter As Double,yCenter As Double _ ,xStart As Double sSQL = "SELECT M.Ordr" _ & ", M.FracLit" _ & ", M.PhaseName" _ & ", M.IsWax" _ & " FROM MoonPhase AS M " _ & " ORDER BY M.Ordr desc" _ & ";" Set db = CurrentDb Set rs = db.OpenRecordset(sSQL,dbOpenDynaset) iLine = 1 iMoon = 1 With Me 'starting coordinates yCenter = .ScaleTop + mRadiusMoon + (mRadiusMoon / 2) xCenter = .ScaleLeft + mRadiusMoon + (mRadiusMoon / 4) xStart = xCenter Do While Not rs.EOF If iMoon Mod (MOONsPerLine + 1) = 0 Then iLine = iLine + 1 yCenter = yCenter + (2 * mRadiusMoon) + (mRadiusMoon / 2) xCenter = xStart End If 'Call Draw_Moon_s4p Call Draw_Moon_s4p(Me,xCenter,yCenter,mRadiusMoon _ ,rs!FracLit,rs!IsWax,gColorPaleYellow,gColorMidnightBlue) 'move X xCenter = xCenter + (2 * mRadiusMoon) + (mRadiusMoon / 2) iMoon = iMoon + 1 rs.MoveNext Loop End With 'me Proc_Exit: On Error Resume Next 'release object variables If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Exit Sub Proc_Err: MsgBox Err.Description,,_ "ERROR " & Err.Number _ & " Detail_Format " & Me.Name Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
Ir al inicio
rpt_Fases lunares_Detalle
Código detrás del informe con 2 columnas que está vinculado a una tabla con datos lunares.
'*************** Code Start CBR *********************************************** ' Purpose : code behind rpt_Moon_Detail ' calls Draw_Moon_s4p ' draw the Moon in the Detail section ' report is 2 columns ' 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) '230212 s4p Dim xCenter As Double,yCenter As Double _ ,sgRadius As Double xCenter = 2.2 * TWIPperINCH yCenter = 1.1 * TWIPperINCH sgRadius = 1 * TWIPperINCH With Me 'Call Draw_Moon_s4p,no outline Call Draw_Moon_s4p(Me,xCenter,yCenter,sgRadius _ ,.FracLit,.IsWax,gColorPaleYellow,gColorMidnightBlue) End With End Sub '*************** Code End *****************************************************
Ir al inicio
rpt_Fases lunares_Órbita
Código que respalda el informe para dibujar las fases de la luna tal como aparecen en su órbita alrededor de la Tierra. Un lado de la luna siempre está oscuro. Dependiendo de dónde se encuentre la luna, es posible que veamos solo una parte de ella. La luna se desplaza en sentido contrario a las agujas del reloj con una velocidad orbital de aproximadamente 2286 millas por hora.
Entre la Tierra y la Luna hay una pequeña luna de referencia con una línea discontinua para el plano que vemos para que puedas entender cómo aparecen las diferentes fases en la Tierra.
'*************** Code Start CBR *********************************************** ' Purpose : code behind rpt_MoonPhases_Orbit ' calls Draw_Moon_s4p ' draw Moons as we see them in orbit around Earth ' 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. '------------------------------------------------------------------------------ ' Report_Page '------------------------------------------------------------------------------ Private Sub Report_Page() '230214 strive4peace ' assume 8 records in the MoonPhase table with moon data ' measurements hard coded for landscape page On Error GoTo Proc_Err Const INCHtoTWIP As Long = 1440 Dim db As DAO.Database _ ,rs As DAO.Recordset Dim sSQL As String _ ,iMoon As Integer _ ,nColorSky As Long Dim xCenterEarth As Double,yCenterEarth As Double _ ,xCenterMoon As Double,yCenterMoon As Double _ ,xCenterReference As Double,yCenterReference As Double _ ,xCenterLine As Double,yCenterLine As Double _ ,dbDistanceMoon As Double _ ,dbDistanceReference As Double _ ,dbDistanceLine As Double _ ,x1 As Double,y1 As Double _ ,x2 As Double,y2 As Double _ ,Y As Double _ ,dbAngleMoon As Double _ ,dbAngleLine As Double Dim dbRadiusEarth As Double _ ,dbRadiusMoon As Double _ ,dbRadiusReference As Double '--------------------- Customize 'Earth radius dbRadiusEarth = 0.75 * INCHtoTWIP 'moon radius dbRadiusMoon = 0.4 * INCHtoTWIP dbRadiusReference = dbRadiusMoon / 2 'distance dbDistanceMoon = 2.5 * INCHtoTWIP dbDistanceReference = dbDistanceMoon * 0.6 dbDistanceLine = dbDistanceReference - dbRadiusReference * 1.2 'center earth xCenterEarth = 3.25 * INCHtoTWIP yCenterEarth = 4.1 * INCHtoTWIP nColorSky = gColorMidnightBlue '--------------------- sSQL = "SELECT M.Ordr" _ & ", M.FracLit" _ & ", M.PhaseName" _ & ", M.IsWax" _ & " FROM MoonPhase AS M " _ & " ORDER BY M.Ordr" _ & ";" Set db = CurrentDb Set rs = db.OpenRecordset(sSQL,dbOpenDynaset) dbAngleMoon = 0 With Me .ScaleMode = 1 'twips .FillStyle = 0 'Opaque .DrawWidth = 6 'pixel .DrawStyle = 0 'solid 'draw sky background x1 = .ScaleLeft x2 = .ScaleLeft + .ScaleWidth y1 = .ScaleTop + .PageHeaderSection.Height y2 = .ScaleTop + .ScaleHeight Me.Line (x1,y1)-(x2,y2),nColorSky,BF 'draw sun 'rays coming from right 'center sun will be right edge 'sun appears to be about the same size as the moon .FillColor = vbYellow Me.Circle (x2,yCenterEarth) _ ,dbRadiusMoon,vbYellow 'draw sun rays from right x1 = x2 - dbRadiusMoon For Y = y1 To y2 Step dbRadiusMoon / 2 Me.Line (x1,Y)-(x2,Y),vbYellow Next Y .DrawWidth = 1 'pixel .FillColor = RGB(0,0,255) 'draw Earth Me.Circle (xCenterEarth,yCenterEarth) _ ,dbRadiusEarth,RGB(0,0,255) 'starting coordinates for Moon xCenterMoon = xCenterEarth + dbDistanceMoon yCenterMoon = yCenterEarth 'starting coordinates for reference Moon xCenterReference = xCenterEarth + dbDistanceReference yCenterReference = yCenterEarth Do While Not rs.EOF 'Call Draw_Moon_s4p Call Draw_Moon_s4p(Me,xCenterMoon,yCenterMoon,dbRadiusMoon _ ,rs!FracLit,rs!IsWax,gColorPaleYellow,gColorMidnightBlue _ ) 'reference moon Call Draw_Moon_s4p(Me,xCenterReference,yCenterReference _ ,dbRadiusReference _ ,0.5,True,vbWhite,vbBlack _ ) 'line of sight .DrawStyle = 2 'dot dbAngleLine = dbAngleMoon + PI / 2 xCenterLine = xCenterEarth + dbDistanceLine * Cos(dbAngleMoon) yCenterLine = yCenterEarth - dbDistanceLine * Sin(dbAngleMoon) x1 = xCenterLine + Cos(dbAngleLine) * dbRadiusReference y1 = yCenterLine - Sin(dbAngleLine) * dbRadiusReference x2 = xCenterLine - Cos(dbAngleLine) * dbRadiusReference y2 = yCenterLine + Sin(dbAngleLine) * dbRadiusReference Me.Line (x1,y1)-(x2,y2),vbWhite .DrawStyle = 0 'solid 'cover back half of reference moon -- future 'calculate next angle and center coordinates dbAngleMoon = dbAngleMoon + PI / 4 xCenterMoon = xCenterEarth + dbDistanceMoon * Cos(dbAngleMoon) yCenterMoon = yCenterEarth - dbDistanceMoon * Sin(dbAngleMoon) xCenterReference = xCenterEarth + dbDistanceReference * Cos(dbAngleMoon) yCenterReference = yCenterEarth - dbDistanceReference * Sin(dbAngleMoon) rs.MoveNext Loop End With 'me Proc_Exit: On Error Resume Next 'release object variables If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Exit Sub Proc_Err: MsgBox Err.Description,,_ "ERROR " & Err.Number _ & " Report_Page " & Me.Name Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
‘El código se generó con colores utilizando el complemento gratuito Color Code para Access.
