Draw the Moon in Access

Quick Jump

Download

Download zipped BAS file you can import into your Access projects: bas_Draw_Moon_s4p.zip

Download zipped ACCDB file with sample data, a module, and sample reports: Draw_Moon_s4p_230214__ACCDB.zip

Remember to UNBLOCK files you download to remove the Mark of the Web. Here are steps to do that: https://msaccessgurus.com/MOTW_Unblock.htm

Try it yourself

There are several sample reports you can play around with

Video

watch on YouTube: Draw the Moon on Access Reports using VBA (0:29)

VBA

Standard module

Specify report object, location and size, and optionally, fraction lit, waxing or waning, and colors.

' 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: https://msaccessgurus.com/VBA/Draw_Moon.htm
' 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) < 0.001 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) < 0.0001 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 *****************************************************

Goto Top  

rpt_MoonPhases_YellowBlue_row

Code behind report to draw 8 phases of the moon. Movement goes from right to left. Code opens a recordset to a table with moon data.

'*************** 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: https://msaccessgurus.com/VBA/Draw_Moon.htm
' 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 *****************************************************

Goto Top  

rpt_MoonPhases_Detail

Code behind report with 2 columns that is bound to a table with moon data.

'*************** 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: https://msaccessgurus.com/VBA/Draw_Moon.htm
' 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 *****************************************************

Goto Top  

rpt_MoonPhases_Orbit

Code behind report to draw phases of the moon as they appear as they orbit around Earth. One side of the moon is always dark. Depending on where the moon is, we may see just part of it. The moon travels in a counter-clockwise direction with an orbital velocity of about 2,286 miles/hour.

Between the Earth and the Moon is a small reference moon with a dashed line for the plane we see so you can understand how the different phases appear on Earth.

'*************** 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: https://msaccessgurus.com/VBA/Draw_Moon.htm
' 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 *****************************************************

Reference

Drawing Reference on MsAccessGurus

Report Draw Reference for VBA syntax and help for drawing on Access reports.

Circle method

DrawWidth property

DrawStyle property

FillColor property

FillStyle property

ScaleMode property

ScaleWidth property

ScaleHeight property

ScaleLeft property

ScaleTop property

Sine function

Cosine function

Backstory

The moon has been keeping me up … instead of sleeping, I want to get up and draw moons!

It was a little tricky figuring out how to make the crescents. Two half circles are drawn, then an oval is drawn on top

Not so easy to get an equation for the moon's positoin because the moon is spinning and revolving around Earth, Earth is spinning and revolving around the sun, and even the sun and our whole solar system is revolving around the big black hole in the Milky Way

Next I want to integrate Moon phases with my CalendarMaker ... sometime!

VBA drawing code with links to more pages with code to draw on your Access reports. If you can imagine it, Access can do it!

If you like this page, please let me know. Donations mean a lot, thank you

Share with others

Get Tutoring with Access and drawing

Let's connect and team-develop your application together. I teach you how to do it yourself. My goal is to empower you.

While we build something great together, I'll pull in code and features from my vast libraries as needed, cutting out lots of development time. I'll give you lots of links to good resources.

Do you want your reports to be more creative and visual? I'd love to help you. Email me at training@msAccessGurus.com

~ crystal

the simplest way is best, but usually the hardest to see