Dibujar un árbol de Navidad en Access

Vba

Módulo estándar

'*************** 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: 
' 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 *****************************************************

Ir arriba

rpt_Árbol de Navidad_Página

Informe de código subyacente para dibujar un árbol de Navidad predeterminado en una página.

'*************** 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: 
' 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 *****************************************************

‘ El código se generó con colores utilizando el complemento gratuito Color Code para Access.