VBA
Standard module
'*************** 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: https://msaccessgurus.com/VBA/Draw_SolsticeDecember.htm
' 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 *****************************************************
Goto Top
rpt_SolsticeDecember
Code behind report to draw the December Solstice with Earth and Sun.
Although different colors can be used, they aren't specified,
so you see the default colors.
'*************** 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: https://msaccessgurus.com/VBA/Draw_Solstice.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()
'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 *****************************************************
' Code was generated with colors using the free
Color Code add-in for Access.
