Draw Birthday Balloons in Access

Quick Jump

Download

Download zipped BAS file you can import into your Access projects: mod_Draw_Balloon_s4p__BAS.zip

Download zipped ACCDB file with a sample report, table, and module: DrawBirthdayBalloons_s4p__ACCDB.zip

Remember to UNBLOCK files you download to remove the Mark of the Web. Here are steps to do that: https://msaccessgurus.com/MOTW_Unblock.htm

Try it yourself

There is a sample report and a table with text

Video

watch on YouTube: How To Draw Birthday Balloons in Access (21:27)

VBA

Standard module

Specify the report object, the XY coordinates of the balloon center, and its radius. Optionally specify text, colors, and more.

Aspect is a fraction referencing the height to width ratio for a circle. Default = 1 -- the balloons use 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: https://msaccessgurus.com/VBA/Draw_BirthdayBalloons.htm
' 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 < 0 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 behind report rDraw_BirthdayBALLOONS

Uses a table with PartyWords and prompts for who the birthday is for (msBIRTHDAY_WHO). Then uses math to position a bunch of balloons on a page with random text chosen from the PartyWords table -- merging in 'Happy Birthday' + msBIRTHDAY_WHO. Color is cycled through an array of colors for a rainbow, starting randomly. Calls Draw_Balloon_s4p to draw a balloon in the specified location with color and text.

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: https://msaccessgurus.com/VBA/Draw_BirthdayBalloons.htm
' 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 < 0 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: https://msaccessgurus.com/VBA/Draw_BirthdayBalloons.htm
' 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 < iMiddleBalloon 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 *****************************************************

Reference

Drawing Reference on MsAccessGurus

Report Draw Reference for VBA syntax and help for drawing on Access reports.

Circle method

Line method

Print method

CurrentX property

CurrentY property

FillStyle property

FillColor property

Microsoft Help

Mod operator

Rnd function

Backstory

I hope you have as much fun with this as I do! You can edit the PartyWords, and make them active or not. Each time you open the sample report, the party words are chosen randomly — except for 'Happy Birthday Name'

Help this site grow by giving a Donation. Access is only limited by your imagination.

Share with others

Get Tutoring with Access and drawing

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. And you'll get links to great resources.

Do you want your reports to be more creative and visual? I'd love to help you. Email me at training@msAccessGurus.com

~ crystal

the simplest way is best, but usually the hardest to see