Dibuja un arcoíris en Access

Vba

Módulo estándar

Especifique la ubicación y el tamaño y, opcionalmente, el color de fondo y los ángulos inicial/final.

'*************** Code Start ***************************************************
' Purpose  : draw a Rainbow on an Access report
'             specify report object,
'             coordinate of the middle of the Rainbow circle,
'                 and radius of the rainbow.
'             Optionally set background color,
'                 and start and end angles
'           USES the Circle method
' Author   : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: 
' Report Draw Reference: 
' 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_Rainbow_s4p
'------------------------------------------------------------------------------
'           Global variables
'------------------------------------------------------------------------------
'comment if defined elsewhere
Public Const PI As Double = 3.14159 
Public Const gZero As Single = 0.0000001 

Private ColorRainbow(1 To 9) As Long 

'------------------------------------------------------------------------------
'           Draw_Rainbow_s4p
' send report object, center coordinate of rainbow circle and radius
'------------------------------------------------------------------------------
Public Sub Draw_Rainbow_s4p(poReport As Report _ 
      ,pXCenter As Single _ 
      ,pYCenter As Single _ 
      ,psgRadius As Single _ 
   ,Optional pnColorBackground As Long = vbWhite _ 
   ,Optional psgAngle1 As Single = gZero _ 
   ,Optional psgAngle2 As Single = PI _ 
   ) 
'230116 s4p
'Draw a Rainbow
'   measurements in twips and radians

   'PARAMETERs
   '  poReport is the Report object
   '  pXCenter is x-coordinate of the middle of the Rainbow circle
   '  pYCenter is y-coordinate of the middle of the Rainbow circle
   '  psgRadius is Rainbow radius
   
   '(Optional)
   '  pnColorBackground, default is white
   '  psgAngle1 start angle, default is zero
   '  psgAngle2 end angle, default is PI
   
   On Error GoTo Proc_Err 
   
   'dimension variables
   Dim sgRadius As Single _ 
      ,i As Integer 

   If ColorRainbow(1) = 0 Then 
      Call setColorsRainbow 
   End If 
   
   'background color in the middle
   ColorRainbow(9) = pnColorBackground 
   
   If psgAngle1 = 0 Then 
      If psgAngle2 = 0 Then 
         Exit Sub 
      End If 
      'zero can't be negative -- use small number
      psgAngle1 = gZero 
   End If 
   
    With poReport 
      
      .ScaleMode = 1  'twips
      .DrawWidth = 1  'pixel

      .FillStyle = 0  'Opaque
      
      sgRadius = psgRadius 
      
      For i = 1 To 9 
         .FillColor = ColorRainbow(i) 
         'negative angles mean to close the shape
         'so it can be filled
         poReport.Circle (pXCenter,pYCenter),sgRadius _ 
            ,ColorRainbow(i),-psgAngle1,-psgAngle2 
         If i = 1 Or i = 8 Then 
            sgRadius = sgRadius - psgRadius / 30  'thin border
         Else 
            sgRadius = sgRadius - psgRadius / 15 
         End If 
      Next i 
      
   End With  'poReport
      
Proc_Exit: 
   On Error GoTo 0 
   Exit Sub 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   Draw_Rainbow_s4p"

   Resume Proc_Exit 
   Resume 
   
End Sub 
'------------------------------------------------------------------------------
'           setColorsRainbow
'------------------------------------------------------------------------------
Sub setColorsRainbow() 
   ColorRainbow(1) = RGB(208,57,46)      'dark Red
   ColorRainbow(2) = RGB(244,67,54)      'Red
   ColorRainbow(3) = RGB(255,152,0)      'Orange
   ColorRainbow(4) = RGB(255,235,59)     'Yellow
   ColorRainbow(5) = RGB(139,195,74)     'Green
   ColorRainbow(6) = RGB(33,150,243)     'Blue
   ColorRainbow(7) = RGB(153,0,255)      'Violet
   ColorRainbow(8) = RGB(99,50,159)      'dark Violet
End Sub 

'*************** Code End *****************************************************

Ir arriba

rpt_Rainbow_Detalle

Informe de código subyacente para dibujar partes de un arco iris según el estado.

'*************** Code Start CBR ***********************************************
' Purpose  : code behind rpt_Rainbow_Detail
'              calls Draw_Rainbow_s4p
'              draw portions of a rainbow
'                 fractions of PI defined in a table for stand and end angles
' 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) 
'230116 crystal
'draw portions of rainbows in the detail section of a report
   'CALLs
   '  Draw_Rainbow_s4p
      
   Dim X As Single,Y As Single _ 
      ,dx As Single,dy As Single _ 
      ,sgRadius As Single _ 
      ,sgAngle1 As Single _ 
      ,sgAngle2 As Single 
      
   With Me 
      
      .ScaleMode = 1  'twips
      
      'width and height for drawing
      dx = 2 * 1440  '1440 twips/inch
      dy = .ScaleHeight 
      
      sgRadius = 1440  '1 inch
      
      'center of rainbow circle
      X = .ScaleLeft + dx / 2 
      Y = .ScaleTop + sgRadius 
   
      sgAngle1 = .StartPI * PI 
      sgAngle2 = .EndPI * PI 
   End With 
   
   'Call Draw_Rainbow_s4p
   Call Draw_Rainbow_s4p(Me,X,Y,sgRadius,,sgAngle1,sgAngle2) 
   
End Sub 
'*************** Code End *****************************************************

Ir arriba

rpt_Rainbow_Page

Informe de código subyacente para dibujar un arco iris en la parte superior de una página.

'*************** Code Start CBR ***********************************************
' Purpose  : code behind rpt_rainbows_Page
'            calls Draw_Rainbow_s4p
'              draw a rainbow 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() 
'230115 crystal
'draw a rainbow at the top of the page
   'CALLs
   '  Draw_Rainbow_s4p
      
   Dim X As Single,Y As Single _ 
      ,dx As Single,dy As Single _ 
      ,sgRadius As Single 
      
   With Me 
      
      .ScaleMode = 1  'twips
      
      'width and height for drawing
      dx = .ScaleWidth 
      dy = .ScaleHeight _ 
         - .PageFooterSection.Height _ 
         - .PageHeaderSection.Height 
      
      If dx > dy Then 
         sgRadius = dy / 2 
      Else 
         sgRadius = dx / 2 
      End If 
      
      'center of rainbow
      X = .ScaleLeft + dx / 2 
      Y = .ScaleTop + .PageHeaderSection.Height _ 
         + sgRadius 
   
   End With 
   
   'Call Draw_Rainbow_s4p
   Call Draw_Rainbow_s4p(Me,X,Y,sgRadius) 
      
End Sub 
'*************** Code End *****************************************************

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