|
Draw a Christmas Tree with a star on top! Just got the tree up today (smile).
Send the report object, top center coordinate and height for the Christmas Tree. Optionally, you can choose colors.
The code that does the drawing is all in one module that you can easily import into your projects. The Christmas Tree uses Circle and Line methods. The star uses Print.
Download zipped BAS file you can import into your Access projects: bas_Draw_Christmas Tree_s4p.zip
Download zipped ACCDB file with sample data, a module, and 2 sample reports: Draw_Christmas Tree_s4p__ACCDB.zip
If you have trouble with a download, you may need to unblock the ZIP file, aka remove Mark of the Web, before extracting the file. Here are steps to do that: https://msaccessgurus.com/MOTW_Unblock.htm
watch on YouTube: Draw Christmas Tree on Access Report (7:36)
'*************** Code Start *************************************************** ' Purpose : draw a Christmas Tree on an Access report ' specify center top coordinate and height ' optionally set colors ' USES Circle, Line, and Print ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: https://msaccessgurus.com/VBA/Draw_ChristmasTree.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_ChristmasTree_s4p '------------------------------------------------------------------------------ ' Global variables '------------------------------------------------------------------------------ 'comment if defined elsewhere Public Const PI As Double = 3.14159 Public Const gColorGreenTree As Long = 6584420 'RGB(100, 120, 100) Public Const gColorBrown As Long = 25750 'RGB(150, 100, 0 Public Const gColorOrange As Long = 38650 'RGB(250, 150, 0) '------------------------------------------------------------------------------ ' Draw_ChristmasTree_s4p ' send report object, top center coordinate and height '------------------------------------------------------------------------------ Public Sub Draw_ChristmasTree_s4p(poReport As Report _ ,pXCenter As Single _ ,pYTop As Single _ ,pYHeight As Single _ ,Optional pnColorTree As Variant = gColorGreenTree _ ,Optional pnColorStar As Variant = vbYellow _ ,Optional pnColorStarOutline As Variant = gColorOrange _ ) '221225 s4p 'Draw a ChristmasTree ' measurements in twips On Error GoTo Proc_Err 'PARAMETERs ' poReport is the Report object ' pXCenter is x-coordinate of Christmas Tree center ' pYTop is y-coordinate of Christmas Tree top ' pYHeight is ChristmasTree height '(Optional) -- long integer color value ' defined as Variant to allow null ' pnColorTree If IsNull(pnColorTree) Then pnColorTree = gColorGreenTree If IsNull(pnColorStar) Then pnColorStar = vbYellow If IsNull(pnColorStarOutline) Then pnColorStarOutline = gColorOrange 'variables Dim X As Single,Y As Single _ ,x1 As Single,y1 As Single _ ,x2 As Single,y2 As Single _ ,sText As String Dim sgRadiusTree As Single _ ,sgAngleTree1 As Single _ ,sgAngleTree2 As Single '----------------------------- customize as desired sgRadiusTree = pYHeight * 0.75 sgAngleTree1 = PI * 1.35 sgAngleTree2 = PI * 1.65 '----------------------------- With poReport .ScaleMode = 1 'twips .DrawWidth = 1 'pixel .FillStyle = 0 'Opaque 'tree stump x1 = pXCenter - (sgRadiusTree * 0.1) x2 = pXCenter + (sgRadiusTree * 0.1) y1 = Y + sgRadiusTree 'tree bottom y2 = Y + pYHeight * 0.9 .FillColor = gColorBrown poReport.Line (x1,y1)-(x2,y2) _ ,gColorBrown,BF 'Tree Y = pYTop + (pYHeight * 0.1) 'tree top .FillColor = pnColorTree poReport.Circle (pXCenter,Y),sgRadiusTree _ ,pnColorTree,-sgAngleTree1,-sgAngleTree2 'star on top .FontName = "Wingdings 2" sText = "ë" 'outline star .FontSize = sgRadiusTree / 75 .ForeColor = pnColorStarOutline .CurrentY = Y - .TextHeight(sText) / 2 .CurrentX = pXCenter - .TextWidth(sText) / 2 .Print sText 'star inside .FontSize = sgRadiusTree / 120 .ForeColor = pnColorStar .CurrentY = Y - .TextHeight(sText) / 2 .CurrentX = pXCenter - .TextWidth(sText) / 2 .Print sText End With Proc_Exit: On Error GoTo 0 Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " Draw_ChristmasTree_s4p" Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
Code behind report to draw a default Christmas Tree on a page.
'*************** Code Start CBR *********************************************** ' Purpose : code behind rpt_ChristmasTrees_Page ' calls Draw_ChristmasTree_s4p ' draw a Christmas Tree on a page ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: https://msaccessgurus.com/VBA/Draw_ChristmasTrees.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() '221216 crystal 'draw a default Christmas Tree on the page 'CALLs ' Draw_ChristmasTree_s4p Dim X As Single,Y As Single _ ,dx As Single,dy As Single _ With Me .ScaleMode = 1 'twips 'width and height for drawing dx = .ScaleWidth dy = .ScaleHeight - .PageFooterSection.Height 'x center X = .ScaleLeft + dx / 2 'y top Y = .ScaleTop End With 'Call Draw_ChristmasTree_s4p Call Draw_ChristmasTree_s4p(Me,X,Y,dy) End Sub '*************** Code End *****************************************************' Code was generated with colors using the free Color Code add-in for Access.
Report Draw Reference for VBA syntax and help for drawing on Access reports.
Merry Christmas! Best wishes to you and your loved ones. So this year is a tree with a star on top. Maybe next year, we can decorate it more (smile).
If you like this page, please let me know. Donations are needed and appreciated, thank you
Here's the link for this page in case you want to copy it and share it with someone:
https://msaccessgurus.com/VBA/Draw_ChristmasTree.htm
or in old browsers:
http://www.msaccessgurus.com/VBA/Draw_ChristmasTree.htm
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
~ crystal
the simplest way is best, but usually the hardest to see