Dibujar un rectángulo redondeado en Access

VBA

Módulo estándar

Especifique el objeto del informe y las coordenadas XY de las esquinas superior izquierda e inferior derecha. Opcionalmente, especifique un ancho para la línea, el color y el tamaño de la esquina.

'module: mod_Draw_RoundRectangle_s4p
'*************** Code Start ***********************************************
' Purpose  : Draw a Rounded Rectangle
' 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.
'-------------------------------------------------------------------------------
'           global variables
'-------------------------------------------------------------------------------
'comment if defined elsewhere
Public Const PI As Double = 3.14159 
Public Const TWIPperINCH As Long = 1440 
'-------------------------------------------------------------------------------
'           Draw_RoundRectangle_s4p
'-------------------------------------------------------------------------------
Sub Draw_RoundRectangle_s4p(oReport As Report _ 
   ,xLeft As Single _ 
   ,yTop As Single _ 
   ,xRight As Single _ 
   ,yBottom As Single _ 
   ,Optional piDrawWidth As Integer = 1 _ 
   ,Optional pnColor As Long = 9868950 _ 
   ,Optional pdbRadiusCorner As Double = 80 _ 
   ) 
   
'use Line to draw lines
'Circle to draw arcs for corners
   Dim x1 As Single,y1 As Single _ 
      ,x2 As Single,y2 As Single 
      
   x1 = xLeft 
   x2 = xRight 
   y1 = yTop + pdbRadiusCorner 
   y2 = yBottom - pdbRadiusCorner 
   
   oReport.DrawWidth = piDrawWidth 
   
   '--- sides
   'left side
   oReport.Line (x1,y1)-(x1,y2),pnColor 
   'right side
   oReport.Line (x2,y1)-(x2,y2),pnColor 
   
   x1 = xLeft + pdbRadiusCorner 
   x2 = xRight - pdbRadiusCorner 
   y1 = yTop 
   y2 = yBottom 
   
   'top
   oReport.Line (x1,y1)-(x2,y1),pnColor 
   'bottom
   oReport.Line (x1,y2)-(x2,y2),pnColor 
   
   '--- corners
   
   x1 = xLeft + pdbRadiusCorner 
   y1 = yTop + pdbRadiusCorner 
   
   '--------------------------------- 'todo: test for big dimensions
   'adjust centers for line width
   x2 = xRight - pdbRadiusCorner _ 
      '+ piDrawWidth * 2 

   y2 = yBottom - pdbRadiusCorner _ 
      '+ piDrawWidth * 2 
   
   'top left corner
   oReport.Circle (x1,y1),pdbRadiusCorner _ 
      ,pnColor,PI / 2,PI 
   'top right corner
   oReport.Circle (x2,y1),pdbRadiusCorner _ 
      ,pnColor,0,PI / 2 
   
   'bottom left corner
   oReport.Circle (x1,y2 ),pdbRadiusCorner _ 
      ,pnColor,PI,3 / 2 * PI 
   'bottom right corner
   oReport.Circle (x2,y2),pdbRadiusCorner _ 
      ,pnColor,3 / 2 * PI,2 * PI 
   
End Sub 

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

Llamada desde el código subyacente del informe r_RoundRectangles_Corner

Utiliza una tabla con números (Numberz) para obtener valores para cambiar el tamaño de las esquinas. ¡Puedes obtener formas que no se parecen en nada a un rectángulo redondeado!

'*************** Code Start CBR ***********************************************
' Purpose  : code behind r_RoundRectangles_Corner
'              calls Draw_RoundRectangle_s4p
'              report is 2 columns
' 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) 
'230212 s4p
   Dim xCenter As Double,yCenter As Double _ 
      ,sgRadius As Double 
   xCenter = 2.2 * TWIPperINCH 
   yCenter = 1.1 * TWIPperINCH 
   sgRadius = 1 * TWIPperINCH 
   
   Dim x1 As Single,y1 As Single _ 
      ,x2 As Single,y2 As Single _ 
      ,sgWidth As Single 

   Dim nColor As Long _ 
      ,dbRadiusCorner As Double _ 
      ,iDrawWidth As Integer 
   
   With Me 
      sgWidth = .Width_ 
      x1 = TWIPperINCH * 0.5 
      x2 = x1 + sgWidth 
      y1 = TWIPperINCH * 0.3 
      y2 = y1 + sgWidth 
      dbRadiusCorner = .Corner 
      iDrawWidth = 4 
      nColor = vbBlue 
   End With 

   
   'Draw_RoundRectangle_s4p
   Call Draw_RoundRectangle_s4p(Me _ 
      ,x1,y1,x2,y2 _ 
      ,iDrawWidth,nColor,dbRadiusCorner _ 
      ) 
      
End Sub 
'*************** Code End *****************************************************

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