VBA
Módulo estándar
Especifique el objeto del informe, las coordenadas XY del centro del globo y su radio. Si lo desea, especifique texto, colores y más.
El aspecto es una fracción que hace referencia a la relación entre la altura y el ancho de un círculo. El valor predeterminado es 1; los globos usan 1,2.
Option Compare Database Option Explicit '*************** Code Start ***************************************************** ' module name: mod_Draw_Balloon_s4p '------------------------------------------------------------------------------- ' Purpose : VBA to draw a balloon on an Access report ' send report object, center coordinate, and size ' optionally colors, text, and more ' 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. Use at your own risk. '------------------------------------------------------------------------------- 'used by GetRandomInteger, not balloon Private mbRandomize As Boolean '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Draw_Balloon_s4p '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sub Draw_Balloon_s4p(oReport As Report _ ,xCenter As Double _ ,yCenter As Double _ ,dbRadius As Double _ ,Optional pnColor As Long = vbYellow _ ,Optional pnBorderColor As Long = -1 _ ,Optional psText As String = "" _ ,Optional piFontSize As Integer = 10 _ ,Optional piFontColor As Long = 16777215 _ ) '220617 strive4peace, 230630 'draw a filled balloon (Aspect=1.2) with pnColor ' slightly offset a black shadow ' draw a string 'psText is made smaller than piFontSize if it won't fit ' ' 'PARAMETERS ' oReport is the Report object ' pnColor is the color for the fill. Default is black ' pnBorderColor will be pnColor if not specified ' psText is text to write in the middle ' piFontSize is (starting) font size to use for text ' piFontColor is color for text, default is white On Error GoTo Proc_Err Dim dbAspect As Double _ ,x1 As Double,y1 As Double _ ,x2 As Double,y2 As Double _ ,i As Integer _ ,iFontSize As Integer _ ,iShadowOffset As Integer iShadowOffset = 40 With oReport .ScaleMode = 1 'twips .DrawWidth = 1 'pixel .FillStyle = 0 'Opaque If pnBorderColor Then pnBorderColor = pnColor End If 'oval shaped balloon dbAspect = 1.2 '.Circle (x,y), Radius, Color, StartAngle, EndAngle, Aspect 'balloon black shadow .FillColor = 0 oReport.Circle (xCenter + iShadowOffset _ ,yCenter + iShadowOffset) _ ,dbRadius _ ,0,,,dbAspect 'balloon .FillColor = pnColor oReport.Circle (xCenter,yCenter) _ ,dbRadius _ ,pnBorderColor,,,dbAspect If psText "" Then .ForeColor = piFontColor iFontSize = piFontSize .FontSize = iFontSize Do While .TextWidth(psText) _ > dbRadius * dbAspect iFontSize = iFontSize - 1 .FontSize = iFontSize Loop .CurrentX = xCenter - .TextWidth(psText) / 2 .CurrentY = yCenter - .TextHeight(psText) / 2 .Print psText End If 'draw bottom 'dbAspect x1 = xCenter - dbRadius / 12 x2 = xCenter + dbRadius / 12 y1 = yCenter + dbRadius y2 = yCenter + dbRadius + dbRadius / 16 'shadow oReport.Line (x1,y1)-(x2 + iShadowOffset _ ,y2 + iShadowOffset _ ),0,BF oReport.Line (x1,y1)-(x2,y2),pnColor,BF 'draw string y1 = y2 y2 = y1 + dbRadius * 2 oReport.Line (xCenter,y1)-( _ xCenter,y2) _ ,RGB(200,200,200) End With Proc_Exit: Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " Draw_Balloon_s4p" Resume Proc_Exit Resume End Sub '=================================================== ' this is needed for example report ' to position and color balloons ' , not to draw a balloon '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' GetRandomInteger '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function GetRandomInteger(piMinumum As Integer _ ,piMaximum As Integer _ ,Optional pDummy As Variant _ ) As Integer 's4p 220616, 708, 230715 'test module variable to only do 'at beginning of a loop or first record of SQL If mbRandomize True Then Randomize mbRandomize = True End If 'Fix instead of Int in case numbers are negative GetRandomInteger = _ Fix( _ ((piMaximum - piMinumum + 1) _ * Rnd) _ + piMinumum) End Function '*************** Code End *****************************************************
Código detrás del informe rDraw_BirthdayBALLOONS
Utiliza una tabla con PartyWords y sugerencias para saber para quién es el cumpleaños (msBIRTHDAY_WHO). Luego, utiliza matemáticas para colocar un montón de globos en una página con texto aleatorio elegido de la tabla PartyWords, fusionando «Feliz cumpleaños» + msBIRTHDAY_WHO. El color se repite en un conjunto de colores para formar un arcoíris, comenzando de manera aleatoria. Dibujar globo s4p Para dibujar un globo en la ubicación especificada con color y texto.
Option Compare Database Option Explicit '*************** Code Start ***************************************************** ' module name: mod_Draw_Balloon_s4p '------------------------------------------------------------------------------- ' Purpose : VBA to draw a balloon on an Access report ' send report object, center coordinate, and size ' optionally colors, text, and more ' 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. Use at your own risk. '------------------------------------------------------------------------------- 'used by GetRandomInteger, not balloon Private mbRandomize As Boolean '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Draw_Balloon_s4p '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sub Draw_Balloon_s4p(oReport As Report _ ,xCenter As Double _ ,yCenter As Double _ ,dbRadius As Double _ ,Optional pnColor As Long = vbYellow _ ,Optional pnBorderColor As Long = -1 _ ,Optional psText As String = "" _ ,Optional piFontSize As Integer = 10 _ ,Optional piFontColor As Long = 16777215 _ ) '220617 strive4peace, 230630 'draw a filled balloon (Aspect=1.2) with pnColor ' slightly offset a black shadow ' draw a string 'psText is made smaller than piFontSize if it won't fit ' ' 'PARAMETERS ' oReport is the Report object ' pnColor is the color for the fill. Default is black ' pnBorderColor will be pnColor if not specified ' psText is text to write in the middle ' piFontSize is (starting) font size to use for text ' piFontColor is color for text, default is white On Error GoTo Proc_Err Dim dbAspect As Double _ ,x1 As Double,y1 As Double _ ,x2 As Double,y2 As Double _ ,i As Integer _ ,iFontSize As Integer _ ,iShadowOffset As Integer iShadowOffset = 40 With oReport .ScaleMode = 1 'twips .DrawWidth = 1 'pixel .FillStyle = 0 'Opaque If pnBorderColor Then pnBorderColor = pnColor End If 'oval shaped balloon dbAspect = 1.2 '.Circle (x,y), Radius, Color, StartAngle, EndAngle, Aspect 'balloon black shadow .FillColor = 0 oReport.Circle (xCenter + iShadowOffset _ ,yCenter + iShadowOffset) _ ,dbRadius _ ,0,,,dbAspect 'balloon .FillColor = pnColor oReport.Circle (xCenter,yCenter) _ ,dbRadius _ ,pnBorderColor,,,dbAspect If psText "" Then .ForeColor = piFontColor iFontSize = piFontSize .FontSize = iFontSize Do While .TextWidth(psText) _ > dbRadius * dbAspect iFontSize = iFontSize - 1 .FontSize = iFontSize Loop .CurrentX = xCenter - .TextWidth(psText) / 2 .CurrentY = yCenter - .TextHeight(psText) / 2 .Print psText End If 'draw bottom 'dbAspect x1 = xCenter - dbRadius / 12 x2 = xCenter + dbRadius / 12 y1 = yCenter + dbRadius y2 = yCenter + dbRadius + dbRadius / 16 'shadow oReport.Line (x1,y1)-(x2 + iShadowOffset _ ,y2 + iShadowOffset _ ),0,BF oReport.Line (x1,y1)-(x2,y2),pnColor,BF 'draw string y1 = y2 y2 = y1 + dbRadius * 2 oReport.Line (xCenter,y1)-( _ xCenter,y2) _ ,RGB(200,200,200) End With Proc_Exit: Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " Draw_Balloon_s4p" Resume Proc_Exit Resume End Sub '=================================================== ' this is needed for example report ' to position and color balloons ' , not to draw a balloon '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' GetRandomInteger '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function GetRandomInteger(piMinumum As Integer _ ,piMaximum As Integer _ ,Optional pDummy As Variant _ ) As Integer 's4p 220616, 708, 230715 'test module variable to only do 'at beginning of a loop or first record of SQL If mbRandomize True Then Randomize mbRandomize = True End If 'Fix instead of Int in case numbers are negative GetRandomInteger = _ Fix( _ ((piMaximum - piMinumum + 1) _ * Rnd) _ + piMinumum) End Function '*************** Code End ***************************************************** '*************** Code Start ***************************************************** ' code behind: rDraw_BirthdayBALLOONS '------------------------------------------------------------------------------- ' Purpose : VBA to draw many balloons on an Access report ' change position, text, and color ' 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. Use at your own risk. '------------------------------------------------------------------------------- '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Private variables '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'comment if defined elsewhere ' defined by SetColorArray_s4p Private manColor(0 To 6) As Long Private Const InchToTWIP As Integer = 1440 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Private msBIRTHDAY_WHO As String '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Report_Open '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Private Sub Report_Open(Cancel As Integer) '220619 strive4peace, 220630, 0716 ' prompt for birthday name Dim sMsg As String sMsg = "(edit the PartyWords table) " _ & "Who is having a birthday?" msBIRTHDAY_WHO = InputBox( _ sMsg _ , "Who is having a birthday?" _ , "") 'replace space with No-Break space If Len(msBIRTHDAY_WHO) > 0 Then msBIRTHDAY_WHO = Replace(Trim(msBIRTHDAY_WHO) _ , " ",Chr(160)) Else msBIRTHDAY_WHO = "!" End If End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ReportHeader_Format '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Private Sub ReportHeader_Format(Cancel As Integer,FormatCount As Integer) '230716 'add name to Label_hApPy BiRtHdAy Me.Label_hApPy_BiRtHdAy.Caption _ = "hApPy_BiRtHdAy " _ & msBIRTHDAY_WHO End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Report_Page '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Private Sub Report_Page() '220618 strive4peace ...230630, Happy birthday! 'draw balloons with words on a full page ' 5 'rows' 'uses PartyWords table 'CALLs ' GetRandomInteger to sort party words ' SetColorArray_s4p ' Draw_Balloon_s4p in mod_Draw_Balloon_s4p On Error GoTo Proc_Err Dim sSQL As String Dim db As DAO.Database _ ,rs As DAO.Recordset Dim iBalloon As Integer _ ,iRow As Integer _ ,iBalloonsInRow As Integer _ ,iMiddleBalloon As Integer _ ,iWordNumber As Integer _ ,iStartWord As Integer _ ,iColorNumber As Integer _ ,bInStartWords As Boolean _ ,xGap As Double _ ,xleft As Double Dim xCenter As Double _ ,yCenter As Double _ ,dbRadius As Double _ ,nColor As Long _ ,nFontColor As Long _ ,sWord As String Dim aStartWords() As String 'msBIRTHDAY_WHO set in Report_Open event aStartWords = Split( "Happy Birthday " & msBIRTHDAY_WHO _ , " ") 'balloon size dbRadius = InchToTWIP '1 inch 'color array to choose from Call SetColorArray_s4p 'start on a random color iColorNumber = GetRandomInteger( _ LBound(manColor) _ ,UBound(manColor)) iStartWord = LBound(aStartWords) bInStartWords = True iWordNumber = 0 iRow = 1 iMiddleBalloon = 3 sSQL = "SELECT W.PartyWord " _ & " FROM PartyWords AS W " _ & " WHERE IsActive 0 " _ & " ORDER BY GetRandomInteger(1,200,(WordID));" Set db = CurrentDb Set rs = db.OpenRecordset(sSQL,dbOpenSnapshot) With Me iBalloonsInRow = 5 xGap = (.ScaleWidth - (iBalloonsInRow * 2 * dbRadius)) _ / (iBalloonsInRow - 1) For iRow = 1 To 5 'if odd, more balloons 'first center If iRow Mod 2 0 Then iBalloonsInRow = 5 iMiddleBalloon = 3 xCenter = .ScaleLeft + dbRadius Else iBalloonsInRow = 4 iMiddleBalloon = 2 xCenter = .ScaleLeft + (dbRadius * 2) _ + xGap / 2 End If If iRow Mod 2 = 0 Then yCenter = .ScaleTop + (dbRadius * 3) _ + (iRow - 1) * dbRadius * 1.8 Else yCenter = .ScaleTop + (dbRadius * 3) _ + (iRow - 1) * dbRadius * 2 End If For iBalloon = 1 To iBalloonsInRow 'GET WORD 'start words are Happy Birthday msBIRTHDAY_WHO 'then every 20 words interject start words iWordNumber = iWordNumber + 1 If bInStartWords Then sWord = aStartWords(iStartWord) iStartWord = iStartWord + 1 If iStartWord > UBound(aStartWords) Then bInStartWords = False End If Else If rs.EOF Then rs.MoveFirst End If sWord = rs!PartyWord rs.MoveNext If iWordNumber Mod 19 = 0 Then 'next time use special words bInStartWords = True iStartWord = LBound(aStartWords) End If End If If iColorNumber > UBound(manColor) Then iColorNumber = LBound(manColor) End If nColor = manColor(iColorNumber) 'colors 0-6 'after 3, uses dark font If iColorNumber = 3 Then 'green nFontColor = RGB(0,0,0) 'black ElseIf iColorNumber > 3 Then nFontColor = RGB(255,255,0) Else nFontColor = RGB(70,120,200) End If '---------------- draw balloon Me.FillColor = nColor Call Draw_Balloon_s4p(Me _ ,xCenter,yCenter,dbRadius _ ,nColor,_ ,sWord,48,nFontColor) 'next color iColorNumber = iColorNumber + 1 'next coordinate xCenter = xCenter + (dbRadius * 2) _ + xGap If iBalloon = iMiddleBalloon _ And iBalloonsInRow Mod 2 = 0 Then 'up just a little yCenter = yCenter - (dbRadius / 3) ElseIf iBalloon Then yCenter = yCenter - dbRadius Else yCenter = yCenter + dbRadius End If Next iBalloon Next iRow End With 'me Proc_Exit: On Error Resume Next 'release object variables If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Exit Sub Proc_Err: MsgBox Err.Description,,_ "ERROR " & Err.Number _ & " Report_Page " & Me.Name Resume Proc_Exit Resume End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' SetColorArray_s4p '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Private Sub SetColorArray_s4p() '230716 currently sets colors of the rainbow ' modifies ganColorRainbow in other places manColor(0) = 510 'red 254, 1, 0 manColor(1) = 4695039 'orange 255, 163, 71 manColor(2) = 65279 'yellow 255, 254, 0 manColor(3) = 195843 'green 3, 253, 2 manColor(4) = 16580609 'blue 1, 0, 253 manColor(5) = 15027094 'purple 209, 0, 203 manColor(6) = 13304017 'violet 209, 0, 203 End Sub '*************** Code End *****************************************************
El código se generó con colores utilizando el complemento gratuito Color Code para Access
